下面的代码从存储在一个文件夹中的* .msg文件中提取附件。
我正在尝试从存储在文件夹内许多子文件夹中的* .msg文件中提取附件。
主文件夹的路径是:U:\ XXXXX \ XXXXX \主文件夹
子文件夹的路径为:U:\ XXXXX \ XXXXX \主文件夹\ Folder1U:\ XXXXX \ XXXXX \主文件夹\ Folder2U:\ XXXXX \ XXXXX \主文件夹\ Folder3等
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
'path for msgs
strFilePath = "U:\XXXXX\XXXXX\Main Folder\"
'path for saving attachments
strAttPath = "D\Attachments\"
strFile = Dir(strFilePath & "*.msg")
Do While Len(strFile) > 0
Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
strFile = Dir
Loop
End Sub
使用我在VBA macro that search for file in multiple subfolders中的答案
Sub SaveOlAttachments()
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String
Dim colFiles As New Collection, f
'path for msgs
strFilePath = "U:\XXXXX\XXXXX\Main Folder\"
GetFiles strFilePath , "*.msg", True, colFiles
'path for saving attachments
strAttPath = "D\Attachments\"
For Each f in colFiles
Set msg = Application.CreateItemFromTemplate(f)
If msg.Attachments.Count > 0 Then
For Each att In msg.Attachments
att.SaveAsFile strAttPath & att.FileName
Next
End If
Next
End Sub
子执行搜索:
Sub GetFiles(StartFolder As String, Pattern As String, _
DoSubfolders As Boolean, ByRef colFiles As Collection)
Dim f As String, sf As String, subF As New Collection, s
If Right(StartFolder, 1) <> "\" Then StartFolder = StartFolder & "\"
f = Dir(StartFolder & Pattern)
Do While Len(f) > 0
colFiles.Add StartFolder & f
f = Dir()
Loop
sf = Dir(StartFolder, vbDirectory)
Do While Len(sf) > 0
If sf <> "." And sf <> ".." Then
If (GetAttr(StartFolder & sf) And vbDirectory) <> 0 Then
subF.Add StartFolder & sf
End If
End If
sf = Dir()
Loop
For Each s In subF
GetFiles CStr(s), Pattern, True, colFiles
Next s
End Sub