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

界面


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

全部代码也可以从http://download.csdn.net/source/643389下载