excel - 在 Excel 中实现 Outlook 宏
问题描述
我在 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
推荐阅读
- c - 将 Char 与 == 和单引号进行比较会给出警告
- jsxgraph - JSXGraph:创建数据图时,“曲线”元素接受什么类型的输入?
- flutter - 为什么在删除 onTap 和 OtherCallBacks 后这个 Flutter 代码不起作用
- vue.js - 使用脚本 ('http://localhost/service-worker.js') 为范围 ('http://localhost/') 注册 ServiceWorker 失败
- java - 如何使用 jooq 获取按聚合值排序的组
- c - 如何在不使用#include的情况下清除C中的终端?
- javascript - 页面加载后如何使用 javascript 删除 404 src 错误?
- matplotlib-basemap - 无法导入/安装底图
- c++ - C++ 重载运算符未导出到 dll
- react-native - 我想用 react-native-youtube 在同一个屏幕上显示几个 youtube 视频