在子文件夹中搜索 .msg 文件并使用 VBA Excel 将其通过 Outlook 邮寄

Question

我正在开展一个项目，以自动化带有 .msg 附件的 Outlook 邮件。发送这些邮件将通过 Excel 进行。我正在使用 VBA Excel 来做到这一点。

在 Excel 中，我有一列包含所需的电子邮件（T 列），另一列（R 列）包含 .msg 文件的一部分名称。文件名的一部分可以包含在一个或多个文件中。如果找到更多文件，则将它们全部邮寄到 T 列中确定的相应邮件。

我对 Excel VBA 有点陌生，但我有一个工作代码可以找到这些文件并将其放在 U 列中的路径中（如果发现两个文件，它们稍后会在代码中分隔在 U 列和V) 使用代码末尾的Outlook邮件发送路径。

我唯一的问题是这些文件分布在子文件夹中，我的代码只有在所有文件都在一个文件夹中时才有效。我使用 (DIR$) 来定位这些带有通配符的文件。如何优化代码以将文件定位在所有子文件夹而不是一个文件夹中？

Sub Send_Files()
Dim OApp As Object
Dim OMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range
Dim irow As Integer
Dim i As Integer
Dim dpath As String
Dim pfile As String
Dim FileNames As String
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim Mail_Object, OutApp As Variant
Dim OutMail As Variant

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With
On Error Resume Next
irow = 1
dpath = "H:\My Documents\test\"
Do While Cells(irow, 18) <> Empty

pfile = Dir$(dpath & "\*" & Cells(irow, 18) & "*")
FileNames = ""
'MsgBox pfile

Do Until LenB(pfile) = 0
    If FileNames <> "" Then
        FileNames = FileNames & ";" & dpath & pfile
    Else
        FileNames = dpath & pfile
    End If
    pfile = Dir$
    For Each cell In Cells(irow, 18)
    Cells(irow, 21) = FileNames

    Next cell

Loop
irow = irow + 1
Loop
'Debug.Print FileNames

Application.DisplayAlerts = False
Columns("V:AU").Select
Selection.ClearContents
Columns("U:U").Select
Selection.TextToColumns Destination:=Range("U1"), DataType:=xlDelimited, _
    TextQualifier:=xlNone, ConsecutiveDelimiter:=False, Tab:=False, _
    Semicolon:=True, Comma:=False, Space:=False, Other:=False, FieldInfo _
    :=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True

Set sh = ActiveSheet

Set OApp = CreateObject("Outlook.Application")

For Each cell In sh.Columns("T").Cells.SpecialCells(xlCellTypeConstants)

    Set rng = sh.Cells(cell.Row, 1).Range("U1:V1")

    If cell.Value Like "?*@testmail.nl" And _
       Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OMail = OApp.CreateItem(0)

        With OMail
            .To = cell.Value
            .Body = "Hoi " & cell.Offset(0, -1).Value
            .Subject = cell.Offset(0, -2).Value
            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    '.Subject = FileCell.Value
                    End If
                End If
             Next FileCell
            .Display
            ' Application.Wait (Now + TimeValue("0:00:01"))
            ' Application.SendKeys "%z"
        End With
        Set OMail = Nothing
    End If
Next cell
  Set OApp = Nothing
With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Answer 1

首先，您的第一个循环中有一个错误

dpath = "H:\My Documents\test\"
.
pfile = Dir$(dpath & "\*" & Cells(irow, 18) & "*")

产生

H:\My Documents\test\\* & Cells(irow, 18) & "*"
                    ^^

您需要将构建 FileNames 列表的代码放入单独的函数中，并将路径和文件掩码传递给该函数。

现在构建该列表的代码在哪里，您将使用另一个 Dir$() 循环来查看文件，但使用 . 文件掩码。它将报告文件和目录。然后测试返回的文件名上设置的 Directory 属性。

llngFileAttribute = GetAttr(<path and name from DIR$()> )
if llngFileAttribute And vbDirectory <> 0 then
    'Is a directory, so add the name from DIR$ to the path
    'and call the list building routine
else
    'call list building routine with path and mask built from cell data
end if

如果您想将多个级别单步执行到目录结构中，则必须将新循环放在另一个函数中并使其递归，仅从现有代码中调用一次。

Answer 2

递归使用 Dir() 有点棘手。全局 Dir() 函数使用单个数据结构来列出它找到的内容，因此如果您从另一个 Dir() 循环中调用 if，初始数据结构将被破坏，并且当您从递归返回时，它不是您所期望的.

这也可以使用 FileSystemObject 来完成，而且会更简单一些。但是由于您在初始代码中使用了 Dir()，所以我使用了它。此示例查找保存工作簿的文件夹中的所有位图文件 (*.bmp) 以及该文件夹下的所有文件夹。

我会留给你修改下面的代码以满足你的需要并探索 FileSystemObject（如果你选择的话）。

变量声明：

第一个字符是变量作用域：l=local;a=传入的参数； m=成员；和 g=global。

作用域后面可以有一个可选的“a”，表示该变量是以下数据类型的数组。

接下来的 3 个字符是数据类型：str=string; lng=长；对象=对象； vnt=变体；等等

后跟一个描述性变量名，每个单词都以大写字母开头。

因此，“lavntSubDirs”是一个局部变量，用作称为 SubDirs 的变体数组。

Subs 没有前缀，因为它们不返回数据。函数有一个前缀表示返回的数据类型。

Option Explicit

Public Sub GetFileList()
    Dim lstrStartingPath As String
    Dim lstrFileNames As String

    'Set starting path as desired
    lstrStartingPath = ThisWorkbook.Path
    'lstrStartingPath = "H:\My Documents\test

'Your row reading loop starts here and sets the 2nd parameter
    lstrFileNames = strRecurseDirs(lstrStartingPath, "*.bmp")
    'lstrFileNames = strRecurseDirs(lstrStartingPath, "*" & Cells(irow, 18) & "*")

    'remove last ";" character
    lstrFileNames = Left$(lstrFileNames, Len(lstrFileNames) - 1)

    'Use the returned string as needed
    MsgBox lstrFileNames

'End of your row reading loop
'.
'.
'.

End Sub
Private Function strRecurseDirs(astrPath As String, astrFileMask As String) As String
    Dim lstrNextDir As String
    Dim lstrFileSpec As String
    Dim llngFileAttr As Long
    Dim lstrFileNameList As String
    Dim lstrSubDirs As String
    Dim lavntSubDirs As Variant
    Dim llngSubDirIdx As Long

    'Get the file names in the passed path
    lstrFileNameList = strGetFileNames(astrPath, astrFileMask)

    'Look for child directories. Because Dir() is a global function and     it uses it's own data structure to return
    'the next item, we can't recurse from within a Dir loop. Since our     strGetFileNames() uses Dir() to find the
    'files it will trash this Dir() loop's item list. So we make a list     of directories found and then recurse for
    'each of the found directories.
    lstrNextDir = Dir(astrPath + "\*.*", vbDirectory)
    Do While Len(lstrNextDir) > 0
        'Note: "." is current directory, ".." is parent directory. We     don't want either.
        If lstrNextDir <> "." And lstrNextDir <> ".." Then
            lstrFileSpec = astrPath + "\" + lstrNextDir
            llngFileAttr = GetAttr(lstrFileSpec)
            If (llngFileAttr And vbDirectory) = vbDirectory Then
                'Is a directory so add it to list of subdirectories to examine
                lstrSubDirs = lstrSubDirs + lstrFileSpec + ";"
            End If
        End If
        lstrNextDir = Dir()
    Loop
    If Len(lstrSubDirs) Then
        'We found subdirectories so process them one at a time

        'Remove last ";" so we don't get an empty string as the last item
        lstrSubDirs = Left$(lstrSubDirs, Len(lstrSubDirs) - 1)

        'Separate the directories found into indiviual items
        lavntSubDirs = Split(lstrSubDirs, ";")

        'Process directories found
        For llngSubDirIdx = 0 To UBound(lavntSubDirs)
            lstrFileNameList = lstrFileNameList + strRecurseDirs(CStr(lavntSubDirs(llngSubDirIdx)), astrFileMask)
        Next
    End If

    strRecurseDirs = lstrFileNameList
End Function
Private Function strGetFileNames(astrPath As String, astrFileMask As String) As String
    Dim lstrFileNameList As String
    Dim lstrFileName As String
    Dim lstrFileSpec As String
    Dim llngFileAttr As Long

    lstrFileName = Dir(astrPath + "\" + astrFileMask)
    Do While Len(lstrFileName) > 0
        lstrFileSpec = astrPath + "\" + lstrFileName
        llngFileAttr = GetAttr(lstrFileSpec)
        If (llngFileAttr And vbDirectory) = 0 Then
            'Not a directory
            lstrFileNameList = lstrFileNameList + lstrFileSpec + ";"
        End If
        lstrFileName = Dir()
    Loop
    strGetFileNames = lstrFileNameList
End Function