Удалось собрать что-то, чтобы пройти через основную папку и забрать файлы msg и извлечь вложения. Я хочу, чтобы код мог также проходить через подпапки. Как мне это сделать? Я видел несколько тем на эту тему, но мне трудно перевести это на то, что у меня есть.
'''
Dim outApp As Object
Dim outEmail As Object
Dim outAttachment As Object
Dim msgfiles As String, sourceFolder As String, saveInFolder As String
Dim fileName As String
msgfiles = "C:\test\*.msg" 'CHANGE - folder location and filespec of .msg files
saveInFolder = "C:\test 2" 'CHANGE - folder where extracted attachments are saved
If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
sourceFolder = Left(msgfiles, InStrRev(msgfiles, "\"))
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
fileName = dir(msgfiles)
While fileName <> vbNullString
'Open .msg file in Outlook 2003
'Set outEmail = outApp.CreateItemFromTemplate(sourceFolder & fileName)
'Open .msg file in Outlook 2007+
Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
For Each outAttachment In outEmail.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
Next
fileName = dir
Wend
'''
РЕДАКТИРОВАТЬ
Включение кода ниже после первого предложения
Sub LoopThrough(parentFolder As String)
Dim fso As Object
' Create a File System object to loop through folders
If fso Is Nothing Then
Set fso = CreateObject("Scripting.FileSystemObject")
End If
' Get the specified folder
Dim folder As Object
Set folder = fso.GetFolder(parentFolder)
' Call my code on it
MyCode msgfiles.Path
' Get all sub folders
Dim subFolder As Object
On Error Resume Next ' We might have permission issues so lets carry on if we get a folder we cannot access
For Each subFolder In folder.subfolders
On Error GoTo 0 ' If we cant access the folder, reset error
If Not subFolder Is Nothing Then ' Folder will be null/nothing if we had an error so ignore it if it is
LoopThrough subFolder.Path
End If
On Error Resume Next ' When going back over the loop we can still get an error
Next
On Error GoTo 0
End Sub
Sub MyCode(folder As String)
Debug.Print folder
msgfiles = folder & "\*.msg"
' Your code Here
Dim outApp As Object
Dim outEmail As Object
Dim outAttachment As Object
Dim msgfiles As String, sourceFolder As String, saveInFolder As String
Dim fileName As String
msgfiles = "C:\test\*.msg" 'CHANGE - folder location and filespec of .msg files
saveInFolder = "C:\test 2" 'CHANGE - folder where extracted attachments are saved
If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
sourceFolder = Left(msgfiles, InStrRev(msgfiles, "\"))
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
If outApp Is Nothing Then
MsgBox "Outlook is not open"
Exit Sub
End If
On Error GoTo 0
fileName = Dir(msgfiles)
While fileName <> vbNullString
'Open .msg file in Outlook 2003
'Set outEmail = outApp.CreateItemFromTemplate(sourceFolder & fileName)
'Open .msg file in Outlook 2007+
Set outEmail = outApp.Session.OpenSharedItem(sourceFolder & fileName)
For Each outAttachment In outEmail.Attachments
outAttachment.SaveAsFile saveInFolder & outAttachment.fileName
Next
fileName = Dir
Wend
End Sub
