VBA开发第五讲-导出邮件到Excel，每个发件人一个Sheet
(如有问题，请联系dsd999@sohu.com)
需求：添加按钮，导出邮件到Excel，每个发件人一个Sheet。
Outlook2003测试通过。
Outlook2007没测试。
代码：
Private WithEvents vsoCommbandButton AsCommandBarButton
Private WithEventsvsoCommbandExportMailToExcel As CommandBarButton
Private Sub Application_Startup()
Call addTotalButton
End Sub
'增加工具栏
Sub addTotalButton()
On Error Resume Next
Dim vsoCommandBar As CommandBar
'得到要添加的工具栏
Set vsoCommandBar =Outlook.ActiveExplorer.CommandBars("ExcelClub")
'如果工具栏为空，则增加
If (vsoCommandBar Is Nothing) Then
Set vsoCommandBar =Outlook.ActiveExplorer.CommandBars.add("ExcelClub", msoBarTop)
'在工具栏上增加一个按钮
Set vsoCommbandExportMailToExcel =vsoCommandBar.Controls.add(1)
vsoCommbandExportMailToExcel.Caption ="ExportToExcel"
vsoCommbandExportMailToExcel.FaceId = 69
vsoCommbandExportMailToExcel.Style =msoButtonIconAndCaption
'显示增加的工具栏
vsoCommandBar.Visible = True
End If
End Sub
'增加的按钮（ExportToExcel）的执行
Private SubvsoCommbandExportMailToExcel_Click(ByVal Ctrl As Office.CommandBarButton,CancelDefault As Boolean)
'出现错误时下一句代码继续运行
On Error Resume Next
Dim xlApp As Object
Dim strPath As String
Dim objShell As Object
Dim objFolder As Object
On Error Resume Next
Set xlApp =CreateObject("Excel.Application")
If xlApp Is Nothing Then Exit Sub
SetobjShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(0,"选择文件夹",0, 0)
If Not objFolder Is Nothing Then
strPath = CStr(objFolder.self.Path)
Else
Exit Sub
End If
Set objFolder = Nothing
Set objShell = Nothing
If Right(strPath, 1) <> "\"Then strPath = strPath + "\"
Dim myWorkbook As Object
Dim myWorksheet As Object
xlApp.DisplayAlerts = False
Set myWorkbook = xlApp.Workbooks.add
myWorkbook.sheets("sheet2").Delete
myWorkbook.sheets("sheet3").Delete
DimobjOutlook As New Outlook.Application
SetmyNameSpace = objOutlook.GetNamespace("MAPI")
Set myFolder =myNameSpace.GetDefaultFolder(olFolderInbox)
Dim objItem As Outlook.mailItem
Dim d1, d2
Dim iSheetIndex As Integer
Set d1 =CreateObject("Scripting.Dictionary")
Set d2 =CreateObject("Scripting.Dictionary")
iSheetIndex = 1
Dim sText As String
Dim iLastRow As Integer
For Each objItem In myFolder.Items
sText = objItem.SenderName
If iSheetIndex = 1 Then
myWorkbook.sheets(1).Name = sText
d1(sText) = iSheetIndex
iSheetIndex = iSheetIndex + 1
Set myWorksheet = myWorkbook.sheets(d1(sText))
myWorksheet.Cells(1, 1) = "Time"
myWorksheet.Cells(1, 2) = "Subject"
myWorksheet.Cells(1, 3) = "Body"
d2(sText) = 2
End If
If d1(sText) = "" Then
d1(sText) = iSheetIndex
iSheetIndex = iSheetIndex + 1
If myWorkbook.sheets(d1(sText)) Is Nothing Then
Set myWorksheet = myWorkbook.sheets.add
myWorksheet.Name = sText
myWorksheet.Cells(1, 1) = "Time"
myWorksheet.Cells(1, 2) = "Subject"
myWorksheet.Cells(1, 3) = "Body"
d2(sText) = 2
Else
Set myWorksheet = myWorkbook.sheets(d1(sText))
End If
End If
iLastRow = d2(sText)
d2(sText) = d2(sText) + 1
myWorksheet.Cells(iLastRow, 1) =objItem.ReceivedTime
myWorksheet.Cells(iLastRow, 2) =objItem.Subject
myWorksheet.Cells(iLastRow, 3) =objItem.Body
Next
myWorkbook.SaveAs strPath & "myMail.xls"
myWorkbook.Close
xlApp.DisplayAlerts = False
Set xlApp = Nothing
MsgBox "Write Finish"
End Sub
谢谢 dsd999
