VBA 桌面文件夹中 .msg 文件的作者和发送日期
VBA Author and sending Date of .msg files on desktop folder
我正在尝试编写一个宏，它遍历桌面文件夹和子文件夹中的 30k+ .msg 文件。如果文件名包含 "Visa Process--" 或 "Document Signed--"，目标是获取发送日期和作者。此外，这只能对最早的文件进行。假设我们在一个子文件夹中，并且有 3 个文件与 "Visa Process--" 相关，那么只考虑最早的文件。
获取发送日期是我目前所做的，但我不知道如何实现获取作者。我激活了 Outlook 加载项，但我是 VBA 的新手，互联网上的示例代码对我有限的知识没有帮助。
非常感谢任何帮助！
很遗憾，我不知道如何在此处为您提供示例文件，但我很乐意通过电子邮件将其发送。
这是我的（工作代码）两种电子邮件类型的发送日期：
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Dim FSO As Object, fld As Object, Fil As Object
Dim fsoFile As Object
Dim fsoFol As Object
Dim fsoSubFol As Object
Dim folderPath As String, subfolderPath As String, folderName As String, FilePath As String
Dim StepOne As String, StepTwo As String, FileName As String, CompareDate As String
Dim NextRow As Long
Dim FindExistingEntry As Range
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Feuil2")
With ws
.UsedRange.Clear
.Cells(1, 1).Value = "Main Folder:"
.Cells(1, 2).Value = "File Name:"
.Cells(1, 3).Value = "MSG Date:"
.Cells(1, 4).Value = "File Name:"
.Cells(1, 5).Value = "Approved Date:"
.Range("A1:E1").Font.Bold = True
End With
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub
folderPath = .SelectedItems(1)
End With
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(folderPath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(folderPath).SubFolders
On Error Resume Next
subfolderPath = fsoFol & "\Mails"
For Each fsoSubFol In FSO.GetFolder(subfolderPath).Files
FilePath = fsoSubFol
FileName = Split(FilePath, "\")(4) 'Get only "Visa Process--2017-06-07 15h24m00s.MSG" of target file 4
folderName = Split(FilePath, "\")(2)
If Mid(FileName, InStrRev(FileName, ".") + 1) = "MSG" Then
'Example: Visa Process--2017-06-07 15h24m00s.MSG
If InStr(1, FileName, "Visa Process--", vbTextCompare) <> 0 And Left(FileName, 1) = "V" Then
NextRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
'Example: Visa Process--2017-06-07 15h24m00s.MSG
StepOne = Split(FileName, "--")(1) 'No "Visa Process--"
StepTwo = Mid(StepOne, 1, 10) 'No Time-Stamp
'Make sure to only include the earliest date for each Main Folder "MPCV....."
Set FindExistingEntry = ws.Range("A2:A4000").Find(folderName)
'If there is already an entry...
If Not FindExistingEntry Is Nothing Then
CompareDate = ws.Cells(FindExistingEntry.Row, 3).Value
'Replace old date for that Main Folder if new date is earlier than previous
If DateValue(CompareDate) > DateValue(StepTwo) Then
ws.Cells(FindExistingEntry.Row, 2).Value = FileName
ws.Cells(FindExistingEntry.Row, 3).Value = DateValue(CompareDate)
'Do nothing if Main Folder date is later
ElseIf DateValue(CompareDate) < DateValue(StepTwo) Then
End If
'If there is no entry for the same Main Folder, simply add a new line
ElseIf FindExistingEntry Is Nothing Then
ws.Cells(NextRow + 1, 1).Value = folderName
ws.Cells(NextRow + 1, 2).Value = FileName
ws.Cells(NextRow + 1, 3).Value = DateValue(StepTwo)
End If
End If
'Do the same for the second document
If InStr(1, FileName, "Document signed--", vbTextCompare) <> 0 And Left(FileName, 1) = "D" Then
NextRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
'Example: Document signed--2017-06-07 15h24m00s.MSG
StepOne = Split(FileName, "--")(1) 'No "Document signed--"
StepTwo = Mid(StepOne, 1, 10) 'No Time-Stamp
'Make sure to only include the earliest date for each Main Folder "MPCV....."
Set FindExistingEntry = ws.Range("A2:A4000").Find(folderName)
'If there is already an entry...
If Not FindExistingEntry Is Nothing Then
CompareDate = ws.Cells(FindExistingEntry.Row, 3).Value
'Replace old date for that Main Folder if new date is earlier than previous
If DateValue(CompareDate) > DateValue(StepTwo) Then
ws.Cells(FindExistingEntry.Row, 4).Value = FileName
ws.Cells(FindExistingEntry.Row, 5).Value = DateValue(CompareDate)
'Do nothing if Main Folder date is later
ElseIf DateValue(CompareDate) < DateValue(StepTwo) Then
End If
'If there is no entry for the same Main Folder, simply add a new line
ElseIf FindExistingEntry Is Nothing Then
'ws.Cells(NextRow + 1, 1).Value = folderName
'ws.Cells(NextRow, 4).Value = Filename
'ws.Cells(NextRow, 5).Value = DateValue(StepTwo)
End If
End If
End If
Next
Next
End If
'Message Box when tasks are completed
MsgBox "Scan Complete!"
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ActiveWorkbook.Saved = True
创建Outlook.Application对象的一个实例（在进入循环之前），从Application.GetNamespace("MAPI")中检索Namespace对象，并使用Namespace.OpenSharedItem传递MSG文件的文件na。检索到的 MailItem 对象将包含 Subject、SenderName、SenderEmailAddress、SentOn 等属性
我正在尝试编写一个宏，它遍历桌面文件夹和子文件夹中的 30k+ .msg 文件。如果文件名包含 "Visa Process--" 或 "Document Signed--"，目标是获取发送日期和作者。此外，这只能对最早的文件进行。假设我们在一个子文件夹中，并且有 3 个文件与 "Visa Process--" 相关，那么只考虑最早的文件。
获取发送日期是我目前所做的，但我不知道如何实现获取作者。我激活了 Outlook 加载项，但我是 VBA 的新手，互联网上的示例代码对我有限的知识没有帮助。
非常感谢任何帮助！
很遗憾，我不知道如何在此处为您提供示例文件，但我很乐意通过电子邮件将其发送。
这是我的（工作代码）两种电子邮件类型的发送日期：
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
Dim ws As Worksheet
Dim FSO As Object, fld As Object, Fil As Object
Dim fsoFile As Object
Dim fsoFol As Object
Dim fsoSubFol As Object
Dim folderPath As String, subfolderPath As String, folderName As String, FilePath As String
Dim StepOne As String, StepTwo As String, FileName As String, CompareDate As String
Dim NextRow As Long
Dim FindExistingEntry As Range
Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Feuil2")
With ws
.UsedRange.Clear
.Cells(1, 1).Value = "Main Folder:"
.Cells(1, 2).Value = "File Name:"
.Cells(1, 3).Value = "MSG Date:"
.Cells(1, 4).Value = "File Name:"
.Cells(1, 5).Value = "Approved Date:"
.Range("A1:E1").Font.Bold = True
End With
Application.DisplayAlerts = False
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
If .Show <> -1 Then MsgBox "No folder selected! Exiting script.": Exit Sub
folderPath = .SelectedItems(1)
End With
If Right(folderPath, 1) <> "\" Then folderPath = folderPath + "\"
Set FSO = CreateObject("Scripting.FileSystemObject")
Set fld = FSO.GetFolder(folderPath)
If FSO.FolderExists(fld) Then
For Each fsoFol In FSO.GetFolder(folderPath).SubFolders
On Error Resume Next
subfolderPath = fsoFol & "\Mails"
For Each fsoSubFol In FSO.GetFolder(subfolderPath).Files
FilePath = fsoSubFol
FileName = Split(FilePath, "\")(4) 'Get only "Visa Process--2017-06-07 15h24m00s.MSG" of target file 4
folderName = Split(FilePath, "\")(2)
If Mid(FileName, InStrRev(FileName, ".") + 1) = "MSG" Then
'Example: Visa Process--2017-06-07 15h24m00s.MSG
If InStr(1, FileName, "Visa Process--", vbTextCompare) <> 0 And Left(FileName, 1) = "V" Then
NextRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
'Example: Visa Process--2017-06-07 15h24m00s.MSG
StepOne = Split(FileName, "--")(1) 'No "Visa Process--"
StepTwo = Mid(StepOne, 1, 10) 'No Time-Stamp
'Make sure to only include the earliest date for each Main Folder "MPCV....."
Set FindExistingEntry = ws.Range("A2:A4000").Find(folderName)
'If there is already an entry...
If Not FindExistingEntry Is Nothing Then
CompareDate = ws.Cells(FindExistingEntry.Row, 3).Value
'Replace old date for that Main Folder if new date is earlier than previous
If DateValue(CompareDate) > DateValue(StepTwo) Then
ws.Cells(FindExistingEntry.Row, 2).Value = FileName
ws.Cells(FindExistingEntry.Row, 3).Value = DateValue(CompareDate)
'Do nothing if Main Folder date is later
ElseIf DateValue(CompareDate) < DateValue(StepTwo) Then
End If
'If there is no entry for the same Main Folder, simply add a new line
ElseIf FindExistingEntry Is Nothing Then
ws.Cells(NextRow + 1, 1).Value = folderName
ws.Cells(NextRow + 1, 2).Value = FileName
ws.Cells(NextRow + 1, 3).Value = DateValue(StepTwo)
End If
End If
'Do the same for the second document
If InStr(1, FileName, "Document signed--", vbTextCompare) <> 0 And Left(FileName, 1) = "D" Then
NextRow = ws.Cells(ws.Rows.Count, 2).End(xlUp).Row
'Example: Document signed--2017-06-07 15h24m00s.MSG
StepOne = Split(FileName, "--")(1) 'No "Document signed--"
StepTwo = Mid(StepOne, 1, 10) 'No Time-Stamp
'Make sure to only include the earliest date for each Main Folder "MPCV....."
Set FindExistingEntry = ws.Range("A2:A4000").Find(folderName)
'If there is already an entry...
If Not FindExistingEntry Is Nothing Then
CompareDate = ws.Cells(FindExistingEntry.Row, 3).Value
'Replace old date for that Main Folder if new date is earlier than previous
If DateValue(CompareDate) > DateValue(StepTwo) Then
ws.Cells(FindExistingEntry.Row, 4).Value = FileName
ws.Cells(FindExistingEntry.Row, 5).Value = DateValue(CompareDate)
'Do nothing if Main Folder date is later
ElseIf DateValue(CompareDate) < DateValue(StepTwo) Then
End If
'If there is no entry for the same Main Folder, simply add a new line
ElseIf FindExistingEntry Is Nothing Then
'ws.Cells(NextRow + 1, 1).Value = folderName
'ws.Cells(NextRow, 4).Value = Filename
'ws.Cells(NextRow, 5).Value = DateValue(StepTwo)
End If
End If
End If
Next
Next
End If
'Message Box when tasks are completed
MsgBox "Scan Complete!"
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
ActiveWorkbook.Saved = True
创建Outlook.Application对象的一个实例（在进入循环之前），从Application.GetNamespace("MAPI")中检索Namespace对象，并使用Namespace.OpenSharedItem传递MSG文件的文件na。检索到的 MailItem 对象将包含 Subject、SenderName、SenderEmailAddress、SentOn 等属性