Question

能够整理一些内容以通过主文件夹并拾取味精文件并提取附件我希望代码也能够遍历子文件夹我将如何处理？我已经看到了有关该主题的一些主题，但是很难将其翻译成我所拥有的

'''

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

Answer 1

这会遍历目录及其子目录。它将调用MyCode并传递文件夹的完整路径。您将需要修改MyCode来完成您想做的事情。

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)
    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

    Debug.Print folder
    msgfiles = folder & "\*.msg"
    ' Your code Here


    ''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

使用excel vba子目录从保存在文件夹中的.msg文件提取附件

1 个答案: