我在Outlook中具有以下宏，并希望通过Excel使用它，如何在不包含Outlook宏的情况下将其重写为可以在excel中运行呢？
Dim objExcelApp As Excel.Application
Dim objExcelWorkbook As Excel.Workbook
Dim objExcelWorksheet As Excel.Worksheet
Public Sub ExportAllFlaggedEmailsToExcel()
Dim objOutlookFile As Outlook.Folder
Dim objFolder As Outlook.Folder
Dim objNameSpace As NameSpace
Dim mailboxowner As Outlook.Recipient
Dim Shared_email_address As Folder
Dim outlookAPP As Outlook.Application
Set outlookAPP = Outlook.Application
Set objOutlookFile = Outlook.Application.Session.PickFolder
Set objNameSpace = Application.GetNamespace("MAPI")
'If Not (objOutlookFile Is Nothing) Then
'Create a new Excel file
Set objExcelApp = CreateObject("Excel.Application")
Set objExcelWorkbook = objExcelApp.Workbooks.Add
Set objExcelWorksheet = objExcelWorkbook.Sheets("sheet1")
objExcelApp.Visible = True
'Name_of_the_excel_file_created_by_the_vba = ActiveWorkbook.Name
'Name_of_the_excel_file_created_by_the_vba.Select
With objExcelWorksheet
.Cells(1, 1) = "Subject"
.Cells(1, 1).Font.Bold = True
.Cells(1, 2) = "Email was sent On"
.Cells(1, 2).Font.Bold = True
.Cells(1, 3) = "From"
.Cells(1, 3).Font.Bold = True
.Cells(1, 4) = "To"
.Cells(1, 4).Font.Bold = True
.Cells(1, 5) = "Categroy"
.Cells(1, 5).Font.Bold = True
End With
For Each objFolder In objOutlookFile.Folders
If objFolder.DefaultItemType = olMailItem Then
Call ProcessMailFolders(objFolder)
End If
Next
objExcelWorksheet.Columns("A:F").AutoFit
MsgBox "Completed!", vbInformation + vbOKOnly, "Export Emails"
'End If
End Sub
Public Sub ProcessMailFolders(ByVal objCurrentFolder As Outlook.Folder)
Dim i As Long
Dim objMail As Outlook.MailItem
Dim objFlaggedMail As Outlook.MailItem
Dim nLastRow As Integer
Dim objSubfolder As Outlook.Folder
'***********************
'Outlook to export categorised emails to excel
'***********************
amount_of_emails = objCurrentFolder.Items.Count
For i = 1 To objCurrentFolder.Items.Count
If objCurrentFolder.Items(i).Class = olMail Then
'Export the information of each flagged email to Excel
Set objMail = objCurrentFolder.Items(i)
On Error Resume Next
If objMail.Categories = "Category_Name" Then
Set objFlaggedMail = objMail
With objExcelWorksheet
nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1
.Range("A" & nLastRow) = objFlaggedMail.Subject
.Range("B" & nLastRow) = objFlaggedMail.SentOn
'.Range("C" & nLastRow) = objFlaggedMail.ReceivedTime
.Range("C" & nLastRow) = objFlaggedMail.SenderName
.Range("D" & nLastRow) = objFlaggedMail.To
.Range("E" & nLastRow) = "Category_Name"
End With
End If
End If
Next i
If objCurrentFolder.Folders.Count > 0 Then
For Each objSubfolder In objCurrentFolder.Folders
Call ProcessMailFolders(objSubfolder)
Next
End If
end sub
我知道不支持从excel调用Outlook函数/宏，因此我想在excel级别上实现它，如何启动它？
查看是否可以修改它以执行所需的操作（从Excel运行）。>>
Option Explicit On
Const fPath As String = "C:\Users\your_path_here\" 'The path to save the messages
Sub Download_Outlook_Mail_To_Excel()
Dim olApp As Object
Dim olFolder As Object
Dim olNS As Object
Dim xlBook As Workbook
Dim xlSheet As Worksheet
Dim NextRow As Long
Dim i As Long
Dim olItem As Object
Set xlBook = Workbooks.Add
Set xlSheet = xlBook.Sheets(1)
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err() <> 0 Then
Set olApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
With xlSheet
.Cells(1, 1) = "Sender"
.Cells(1, 2) = "Subject"
.Cells(1, 3) = "Date"
.Cells(1, 4) = "Size"
.Cells(1, 5) = "EmailID"
.Cells(1, 6) = "Body"
CreateFolders fPath
Set olNS = olApp.GetNamespace("MAPI")
Set olFolder = olNS.PickFolder
For Each olItem In olFolder.Items
NextRow = .Cells(.Rows.Count, "A").End(xlUp).Row + 1
If olItem.Class = 43 Then
.Cells(NextRow, 1) = olItem.Sender
.Cells(NextRow, 2) = olItem.Subject
.Cells(NextRow, 3) = olItem.SentOn
'.Cells(NextRow, 4) =
.Cells(NextRow, 5) = SaveMessage(olItem)
'.Cells(NextRow, 6) = olItem.Body 'Are you sure?
End If
Next olItem
End With
MsgBox "Outlook Mails Extracted to Excel"
lbl_Exit:
Set olApp = Nothing
Set olFolder = Nothing
Set olItem = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
End Sub
Function SaveMessage(olItem As Object) As String
Dim Fname As String
Fname = Format(olItem.ReceivedTime, "yyyymmdd") & Chr(32) &
Format(olItem.ReceivedTime, "HH.MM") & Chr(32) & olItem.sendername & " - " & olItem.Subject
Fname = Replace(Fname, Chr(58) & Chr(41), "")
Fname = Replace(Fname, Chr(58) & Chr(40), "")
Fname = Replace(Fname, Chr(34), "-")
Fname = Replace(Fname, Chr(42), "-")
Fname = Replace(Fname, Chr(47), "-")
Fname = Replace(Fname, Chr(58), "-")
Fname = Replace(Fname, Chr(60), "-")
Fname = Replace(Fname, Chr(62), "-")
Fname = Replace(Fname, Chr(63), "-")
Fname = Replace(Fname, Chr(124), "-")
SaveMessage = SaveUnique(olItem, fPath, Fname)
lbl_Exit:
Exit Function
End Function
Private Function SaveUnique(oItem As Object,
strPath As String,
strFileName As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(strFileName)
Do While FileExists(strPath & strFileName & ".msg") = True
strFileName = Left(strFileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
oItem.SaveAs strPath & strFileName & ".msg"
SaveUnique = strPath & strFileName & ".msg"
lbl_Exit:
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
Dim strTempPath As String
Dim iPath As Long
Dim vPath As Variant
vPath = Split(strPath, "\")
strPath = vPath(0) & "\"
For iPath = 1 To UBound(vPath)
strPath = strPath & vPath(iPath) & "\"
If Not FolderExists(strPath) Then MkDir strPath
Next iPath
End Sub
Private Function FolderExists(ByVal PathName As String) As Boolean
Dim nAttr As Long
On Error GoTo NoFolder
nAttr = GetAttr(PathName)
If (nAttr And vbDirectory) = vbDirectory Then
FolderExists = True
End If
NoFolder:
End Function
Private Function FileExists(filespec) As Boolean
Dim fso As Object
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(filespec) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function