outlook插件邮件群发系统 outlook添加按钮 outlook添加窗口

最新推荐文章于 2022-03-31 22:33:01 发布

weixu_2008

最新推荐文章于 2022-03-31 22:33:01 发布

阅读量3.9k

点赞数

分类专栏： vba 文章标签： email c date web

本文链接：https://blog.csdn.net/weixu_2008/article/details/2963779

版权

vba 专栏收录该内容

4 篇文章 0 订阅

订阅专栏

界面

thisoutlooksession

---------------
Option Explicit
'Private WithEvents olOutboxItems As Items
'----------------
'Private WithEvents Importbtn As Office.CommandBarButton
Private WithEvents SendMailbtn As Office.CommandBarButton
Public WithEvents myControl As Office.CommandBarButton
'----------------
Dim objNS As NameSpace
'----------------
Dim MailAddFile As String
'Added by Zheng
Public Flag As Boolean
Public WithEvents myItem As mailItem
Public WithEvents colInsp As Outlook.Inspectors
Public WithEvents colCustomersItems As Outlook.Items
Public WithEvents olInboxItems As Outlook.Items
Public tempFolder As Outlook.MAPIFolder
Dim emailReg As String
Private Sub Application_Quit()
'----------------
' Set olOutboxItems = Nothing
' Set objNS = Nothing
'----------------
End Sub
Private Sub Application_Startup()
'----------------
emailReg = "[A-Za-z0-9_]+[A-Za-z0-9_/-]*(/.[A-Za-z0-9_]+[A-Za-z0-9_/-]*)*@[A-Za-z0-9_]+[A-Za-z0-9_/-]*(/.[A-Za-z0-9_]+[A-Za-z0-9_/-]*)*/.[A-Za-z]{2,6}"
Set objNS = Application.GetNamespace("MAPI")
' Set olOutboxItems = objNS.GetDefaultFolder(olFolderOutbox).Items
Set olInboxItems = objNS.GetDefaultFolder(olFolderInbox).Items
'----------------
'MailAddFile = "c:/YiFanMu/MailSys/MailAddress.xls"
'Call CreateFile(MailAddFile)
Call CreateFile("C:/YiFanMu/MailSys/Templates/")
Dim oExplorer As Outlook.Explorer
Set oExplorer = Application.ActiveExplorer
'Set Importbtn = CreateCommandBarButton(oExplorer.CommandBars, "导入收件人地址 ")
Set SendMailbtn = CreateCommandBarButton(oExplorer.CommandBars, "邮件群发")
End Sub
'Private Sub Importbtn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
' MsgBox "Click: " & Ctrl.Caption
'End Sub
Private Sub SendMailbtn_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
UserForm1.Show
End Sub
Public Function CreateCommandBarButton(oBars As Office.CommandBars, str As String) As Office.CommandBarButton
On Error Resume Next
Dim oMenu As Office.CommandBar
Dim oBtn As Office.CommandBarButton
Set oMenu = oBars(str)
If oMenu Is Nothing Then
Set oMenu = oBars.Add(str, msoBarTop, , True)
Set oBtn = oMenu.Controls.Add(msoControlButton, , str, , True)
oBtn.Caption = str
oBtn.Tag = str
oBtn.FaceId = 1130
Else
Set oBtn = oMenu.FindControl(, , str)
If oBtn Is Nothing Then
Set oBtn = oMenu.Controls.Add(msoControlButton, , str, , True)
oBtn.Caption = str
oBtn.Tag = str
End If
End If
oMenu.Visible = True
Set CreateCommandBarButton = oBtn
End Function
Public Sub CreateFile(sFilePath)
Dim oFSO As Object
Dim nPosition As Integer
nPosition = InStr(1, sFilePath, "/", 0)
Set oFSO = CreateObject("Scripting.FileSystemObject")
While (nPosition <> 0)
If (Not oFSO.FolderExists(Mid(sFilePath, 1, nPosition))) Then
oFSO.CreateFolder (Mid(sFilePath, 1, nPosition))
End If
nPosition = InStr(nPosition + 1, sFilePath, "/", 0)
Wend
' If (Not oFSO.FileExists(sFilePath)) Then
' oFSO.CreateTextFile (sFilePath)
' End If
Set oFSO = Nothing
End Sub
'Private Sub Application_ItemSend(ByVal Item As Object, Cancel As Boolean)
' Dim NewMailItem As Outlook.mailItem
' Dim count As Long
' count = Item.Recipients.count
' If count > 1 Then
' Cancel = False
' Set NewMailItem = Item
'NewMailItem.GetInspector.Close olDiscard
'Call createTempFolder
'MsgBox (tempFolder)
'Item.Move (tempFolder)
' End If
''On Error Resume Next
' If Item.Class = olMail Then
' If Item.Recipients.count <> 1 Then
' For i = 1 To Item.Recipients.count
' Set NewMailItem = Item.Copy
' For j = NewMailItem.Recipients.count To 1 Step -1
' NewMailItem.Recipients.Remove (j)
' Next
' NewMailItem.Recipients.Add (Item.Recipients.Item(i))
' NewMailItem.Send
' Next
'NewMailItem.se
' Item.Close olSave
' End If
' End If
'End Sub
'Private Sub createTempFolder()
' Dim mpfRoot As Outlook.MAPIFolder
' Dim mpf As Outlook.MAPIFolder
' Dim isTempExist As Boolean
' isTempExist = False
' Set mpf = Application.Session.GetDefaultFolder(olFolderInbox)
' Set mpfRoot = mpf.Parent
' Dim eachFolder As MAPIFolder
' Dim x As MAPIFolder
' For Each x In mpfRoot.Folders
' If x.Name = "temp" Then
' isTempExist = True
' Set tempFolder = x
' Exit For
' End If
' Next x
' If Not isTempExist Then
' Set tempFolder = mpfRoot.Folders.Add("temp")
' End If
'End Sub
'Private Sub removeTempFolder()
' Dim mpfRoot As Outlook.MAPIFolder
' Dim mpf As Outlook.MAPIFolder
' Dim isTempExist As Boolean
' isTempExist = False
' Set mpf = Application.Session.GetDefaultFolder(olFolderInbox)
' Set mpfRoot = mpf.Parent
' Dim eachFolder As MAPIFolder
' Dim x As MAPIFolder
' For Each x In mpfRoot.Folders
' If x.Name = "temp" Then
' x.Delete
' Exit For
' End If
' Next x
'End Sub
'Private Sub olOutboxItems_ItemAdd(ByVal Item As Object)
'Dim myReply As Outlook.mailItem
'Dim i, j As Integer
'On Error Resume Next
' If Item.Class = olMail And Not TypeName(Item) = "Nothing" Then
' If Item.Recipients.count > 1 Then
' For i = 1 To Item.Recipients.count
' Set myReply = Item.Copy
' If Not TypeName(myReply) = "Nothing" Then
' For j = myReply.Recipients.count To 1 Step -1
' myReply.Recipients.Remove (j)
' Next
' myReply.Recipients.Add (Item.Recipients.Item(i))
' myReply.Send
' End If
' Next
' Set myReply = Nothing
' Item.Delete
' End If
' Set Item = Nothing
' End If
'End Sub
Private Sub olInboxItems_ItemAdd(ByVal Item As Object)
' Dim subj As String
' Dim senderName As String
' Dim senderAddr As String
' Dim body As String
' Dim regExp As regExp
' Dim matches As Object
' Dim failedAddr As String
' If typeName(Item) = "MailItem" Then
' subj = Item.subject
' senderName = Item.senderName
' senderAddr = Item.SenderEmailAddress
' If senderName = "Mail Delivery System" And (senderAddr = "MAILER-DAEMON@sina.com" Or senderAddr = "MAILER-DAEMON@smtp.sina.com.cn") Then
' body = Item.body
' Set regExp = New regExp
' regExp.Pattern = emailReg
' Set matches = regExp.Execute(body)
' If matches.count >= 0 Then
' failedAddr = matches(0).Value
' If senderAddr = "MAILER-DAEMON@sina.com" Then
' Call logEmailNotFound(failedAddr)
' End If
' If senderAddr = "MAILER-DAEMON@smtp.sina.com.cn" Then
' Call logEmailNotSent(failedAddr)
' End If
' Item.Close olDiscard
' Item.Delete
' End If
' End If
' End If
End Sub
Private Sub log(file As String, msg As String)
Dim now
now = "[" & Date & " " & Time & "] "
Open file For Append As #1
Print #1, now & msg
Close #1
End Sub
Private Sub logInvalidEmail(email As String)
Call log("c:/YiFanMu/MailSys/bademail.log", "邮件地址错误: " & email)
End Sub
Private Sub logEmailNotFound(email As String)
Call log("c:/YiFanMu/MailSys/notfound.log", "邮件地址未找到: " & email)
End Sub
Private Sub logEmailNotSent(email As String)
Call log("c:/YiFanMu/MailSys/failed.log", "邮件发送失败: " & email)
End Sub
Public Sub clearBadMail()
Dim objMAPIFolder As MAPIFolder
Dim totalNumber As Long
Dim i As Integer
Dim objMailItem As mailItem
Set objMAPIFolder = Application.Session.GetDefaultFolder(FolderType:=olFolderDeletedItems)
totalNumber = objMAPIFolder.Items.count
If totalNumber >= 1 Then
For i = totalNumber To 1 Step -1 ' 清除已删除邮件中邮件!
' DoEvents
Set objMailItem = objMAPIFolder.Items(i)
If Left(objMailItem.subject, 8) = "BADADDR_" Then
objMailItem.Close olDiscard
objMailItem.Delete
End If
Next i
End If
End Sub
Private Sub myControl_Click(ByVal Ctrl As Office.CommandBarButton, CancelDefault As Boolean)
Dim NewMailItem As Outlook.mailItem, Item As Outlook.mailItem, tmpMailItem As Outlook.mailItem
Dim i, j, k As Integer
Dim count As Long
Dim tempAddr As String
Dim reg As regExp
Set reg = New regExp
reg.Pattern = "^" & emailReg & "$"
i = 0
j = 0
k = 0
Dim arr() As String
Dim rec As Recipient
Dim validAddrs() As String
Dim temp As String
Dim addrLen As Long
If Application.ActiveInspector.CurrentItem.Class = olMail Then
Set Item = Application.ActiveInspector.CurrentItem.Copy
Application.ActiveInspector.CurrentItem.Close olDiscard
If Item.Recipients.count <> 1 Then
addrLen = -1
count = Item.Recipients.count
For i = count To 1 Step -1
temp = Item.Recipients.Item(i)
' arr = Split(temp, "<")
' If UBound(arr) > 0 Then
' tempAddr = Left(arr(1), Len(arr(1)) - 1)
' Else
tempAddr = temp
' End If
' MsgBox (tempAddr)
If reg.test(tempAddr) Then
addrLen = addrLen + 1
Else
Call logInvalidEmail(tempAddr)
Item.Recipients.Remove (i)
End If
Next i
If addrLen >= 0 Then
ReDim validAddrs(addrLen)
count = Item.Recipients.count
For i = 1 To Item.Recipients.count
temp = Item.Recipients.Item(i)
arr = Split(temp, "<")
If UBound(arr) > 0 Then
tempAddr = Left(arr(1), Len(arr(1)) - 1)
Else
tempAddr = temp
End If
validAddrs(i - 1) = tempAddr
Next i
For j = Item.Recipients.count To 1 Step -1
Item.Recipients.Remove (j)
Next j
If addrLen > 0 Then
' tmpMailItem = Item.Copy
' For j = tmpMailItem.Recipients.count To 1 Step -1
' tmpMailItem.Recipients.Remove (j)
' Next j
For i = LBound(validAddrs) To UBound(validAddrs)
tempAddr = validAddrs(i)
If i < UBound(validAddrs) Then
Set NewMailItem = Item.Copy
Else
Set NewMailItem = Item
End If
NewMailItem.Recipients.Add (tempAddr)
NewMailItem.Send
Next i
Else
Item.Close olDiscard
Item.Delete
End If
Set NewMailItem = Nothing
Else
Item.Close olDiscard
Item.Delete
End If
Set Item = Nothing
End If
End If
End Sub

userform1

 
 
Dim templatePath As String
Private Sub DeselectAllbtn_Click()
    Dim count As Long
    count = MailAdrtrv.Nodes.count
    For i = 1 To count
        MailAdrtrv.Nodes.Item(i).Checked = False
    Next
End Sub
Private Sub SelectAllbtn_Click()
    Dim count As Long
    count = MailAdrtrv.Nodes.count
    For i = 1 To count
        MailAdrtrv.Nodes.Item(i).Checked = True
    Next
End Sub
Private Sub UserForm_Initialize()
    Dim strnode As String
    Dim tvnode As node
    Dim i, j As Long
    Dim FSO As Object
    Dim TemplateOptionbtn ' As OptionButton 
    Dim TemplateOptionbtnCount As Integer
    
    With Me.Frame2
        'This will create a vertical scrollbar 
        .ScrollBars = fmScrollBarsVertical
        'Change the values of 2 as Permission your requirements 
        .ScrollHeight = .InsideHeight * 2
        .ScrollWidth = .InsideWidth * 9
    End With
   
    templatePath = "C:/YiFanMu/MailSys/Templates"
    MailAddFile = "c:/YiFanMu/MailSys/MailAddress.xls"
    
    MailAdrtrv.Nodes.Clear
    i = 0
    j = 0
    ' RETRIEVE DATA FROM FILE 
    ' Open file for input. 
'    Open MailAddFile For Input As #1 
    ' Loop until the end of file is reached. 
'    Do While Not EOF(1) 
    ' Read data into variables. 
'    i = i + 1 
'    Input #1, strnode 
'    If InStr(1, strnode, "@") = 0 Then 
'        j = i 
'        Set tvnode = MailAdrtrv.Nodes.Add(, , , strnode) 
'    Else 
'        Set tvnode = MailAdrtrv.Nodes.Add(j, tvwChild, , strnode) 
'    End If 
'    Loop 
'    ' Close file. 
'    Close #1 
    
    Dim xlApp As Excel.Application
    Dim xlWb As Excel.Workbook
    Dim xlWs As Excel.Worksheet
    Dim Rng As Excel.Range
    Dim typeName As String
    Dim clientName As String
    Dim email As String
'    Dim newEmail As String 
    Dim rowCount As Long
    Dim currentTypeId As Long
    Dim parentId As Long
    currentTypeId = 0
    parentId = 0
    
    Dim arra() As String
    Dim eachAddr As String
    
    Set xlApp = ThisOutlookSession.CreateObject("Excel.Application")
    Set xlWb = xlApp.Workbooks.Open(CStr(MailAddFile))
    
    For Each xlWs In xlWb.Worksheets
        typeName = xlWs.name
        'add the parent node here 
        Set tvnode = MailAdrtrv.Nodes.Add(, , , typeName)
        currentTypeId = currentTypeId + 1
        parentId = currentTypeId
        Set Rng = xlWs.Range("A1")
        rowCount = Rng.Cells(xlWs.Rows.count, 1).End(xlUp).Row
        For i = 2 To rowCount Step 1
            clientName = xlWs.Cells(i, 3).Value
            email = xlWs.Cells(i, 5).Value
            
            arra = Split(email, "/")
            For j = LBound(arra) To UBound(arra)
                
'            newEmail = xlWs.Cells(i, 6).Value 
'            If newEmail <> "" Then 
'                email = newEmail 
'            End If 
                If arra(j) <> "" Then
    '                MsgBox (typeName & ": " & clientName & "(" & email & ")") 
                    'add child node here 
                    Set tvnode = MailAdrtrv.Nodes.Add(parentId, tvwChild, , clientName & "<" & arra(j) & ">")
                    currentTypeId = currentTypeId + 1
                End If
            Next
        Next i
    Next xlWs
    
    xlWb.Close (False)
    Set Rng = Nothing
    Set xlWs = Nothing
    Set xlWb = Nothing
    Set xlApp = Nothing
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    TemplateOptionbtnCount = 0
    Dim fFile As Object
    Dim fPatten As String
    Dim w1 As String
    fPatten = "oft"
    w1 = ""
    For Each fFile In FSO.GetFolder(templatePath).Files
        If UCase$(fPatten) = UCase$(FSO.GetExtensionName(fFile.Path)) Then
            'MsgBox (fFile.Name) 
            TemplateOptionbtnCount = TemplateOptionbtnCount + 1
            
             Set TemplateOptionbtn = Me.Frame2.Controls.Add("Forms.OptionButton.1", , True)
             With TemplateOptionbtn
                .Caption = Mid(fFile.name, 1, InStr(1, fFile.name, ".oft") - 1)
                .Top = 8 + (TemplateOptionbtnCount - 1) * 15
                .Left = 8
                .Height = 15
             End With
        End If
    Next
    Set FSO = Nothing
End Sub
Private Sub WriteMailbtn_Click()
    Dim selectItem 'As OptionButton 
    Dim NewMailItem As Outlook.mailItem
    Dim tempSelected As Boolean
    tempSelected = False
     
    UserForm1.Hide
    For Each x In Me.Frame2.Controls
        If x.Value = True Then
            Set selectItem = x
            tempSelected = True
            Exit For
        End If
    Next
    
    If tempSelected Then 'modified by zheng 
        Set NewMailItem = Application.CreateItemFromTemplate(templatePath & "/" & selectItem.Caption & ".oft")
        Call SetReceiveMailAdd(NewMailItem, MailAdrtrv)
    Else
        Set NewMailItem = Application.CreateItem(olMailItem)
        Call SetReceiveMailAdd(NewMailItem, MailAdrtrv)
    End If
    NewMailItem.Display
    Dim oExplorer As Outlook.Inspector
    Set oExplorer = NewMailItem.GetInspector
    Set ThisOutlookSession.myControl = ThisOutlookSession.CreateCommandBarButton(oExplorer.CommandBars, "邮件群发发送 ")
End Sub
Private Sub SetReceiveMailAdd(mailItem, tvHandle)
    'Added by Zheng 
    Dim email As String
    Dim count As Long
    Dim tempAddr As String
    Dim arr() As String
    
    For i = mailItem.Recipients.count To 1 Step -1 'modified by zheng 
        mailItem.Recipients.Remove (i)
    Next
    
    count = MailAdrtrv.Nodes.count
    For i = 1 To count
        If MailAdrtrv.Nodes.Item(i).Checked Then
            email = MailAdrtrv.Nodes.Item(i)
            If InStr(1, email, "<") <> 0 Then
                arr = Split(email, "<")
                If UBound(arr) > 0 Then
                    tempAddr = Left(arr(1), Len(arr(1)) - 1)
                Else
                    tempAddr = email
                End If
                mailItem.Recipients.Add (tempAddr)
            End If
        End If
       
    Next
  
End Sub
'Added by Zheng 
Private Sub MailAdrtrv_NodeCheck(ByVal node As MSComctlLib.node)
  Dim id As Long
  Dim isChecked As Boolean
  id = node.Index
  isChecked = node.Checked
  Dim i As Long
  Dim count As Long
  Dim email As String
  count = MailAdrtrv.Nodes.count
  If InStr(1, node, "<") = 0 Then
     For i = id + 1 To count
        email = MailAdrtrv.Nodes.Item(i)
        If InStr(1, email, "<") = 0 Then
            Exit For
        Else
            MailAdrtrv.Nodes.Item(i).Checked = isChecked
        End If
     Next
  End If
  
End Sub
Sub EnumCommandBars()
    Dim objOL As Outlook.Application
    Dim objNS As Outlook.NameSpace
    Dim objDrafts As Outlook.MAPIFolder
    Dim objPost As Outlook.PostItem
    Dim colCB As Office.CommandBars
    Dim objCB As Office.CommandBar
    Dim strWindow As String
    Dim strExplBars As String
    Dim strInspBars As String
    Dim strText As String
    Dim arrBars() As String
    Dim i As Integer
    On Error Resume Next
    Set objOL = Application
    Set objNS = objOL.Session
    Set objDrafts = objNS.GetDefaultFolder(olFolderDrafts)
    strExplBars = "Menu Bar,Standard,Advanced,Web"
    strInspBars = "Menu Bar,Standard,Form Design,Formatting"
    strWindow = typeName(objOL.ActiveWindow)
    Select Case strWindow
        Case "Explorer"
            Set colCB = objOL.ActiveExplorer.CommandBars
            arrBars = Split(strExplBars, ",")
        Case "Inspector"
            Set colCB = objOL.ActiveInspector.CommandBars
            arrBars = Split(strInspBars, ",")
    End Select
    If Not colCB Is Nothing Then
        Set objPost = objDrafts.Items.Add("IPM.Post")
        objPost.subject = "CommandBars for " & strWindow & _
                          ": " & colCB.Parent.Caption
        objPost.BodyFormat = olFormatPlain
        For i = 0 To UBound(arrBars)
            Set objCB = colCB.Item(arrBars(i))
            Call EnumOneBar(objCB, strText)
            strText = strText & vbCrLf & "===========" & vbCrLf
        Next
        objPost.body = Mid(strText, 5)
        objPost.Save
        objPost.Display
    End If
    Set objOL = Nothing
    Set objNS = Nothing
    Set objDrafts = Nothing
    Set objPost = Nothing
    Set colCB = Nothing
    Set objCB = Nothing
End Sub
Sub EnumOneBar(cb As Office.CommandBar, ByRef postText)
    Dim objControl As Office.CommandBarControl
    Dim objPopupControl As Office.CommandBarPopup
    postText = postText & vbCrLf & vbCrLf & "CommandBar: " & cb.name
    For Each objControl In cb.Controls
        If objControl.BuiltIn = True Then
            Select Case objControl.Type
                Case msoControlPopup, _
                     msoControlButtonPopup, _
                     msoControlGraphicPopup, _
                     msoControlSplitButtonPopup
                    postText = postText & vbCrLf & vbCrLf & _
                      objControl.Caption & _
                      " (Submenu) - " & objControl.id
                    Set objPopupControl = objControl
                    If objControl.id = 5577 Then
                        MsgBox "ss"
                    End If
                    Call EnumOneBar( _
                      objPopupControl.CommandBar, postText)
                 Case Else
                    postText = postText & vbCrLf & vbTab & _
                      objControl.Caption & " - " & objControl.id
                    If objControl.id = 5577 Then
                        MsgBox "ss"
                    End If
            End Select
        End If
    Next
    Set objControl = Nothing
    Set objPopupControl = Nothing
End Sub
Sub FindSendBtn(cb As Office.CommandBar)
    Dim objControl As Office.CommandBarControl
    Dim objPopupControl As Office.CommandBarPopup
    For Each objControl In cb.Controls
        If objControl.BuiltIn = True Then
            Select Case objControl.Type
                Case msoControlPopup, _
                     msoControlButtonPopup, _
                     msoControlGraphicPopup, _
                     msoControlSplitButtonPopup
                    Set objPopupControl = objControl
                    If objControl.id = 5577 Then
                        objControl.Visible = False
                    End If
                    Call FindSendBtn(objPopupControl.CommandBar)
                 Case Else
                    If objControl.id = 5577 Then
                        objControl.Visible = False
                    End If
            End Select
        End If
    Next
    Set objControl = Nothing
    Set objPopupControl = Nothing
End Sub
 