如何将文件夹中的所有文件附加到电子邮件 - vba 代码

Question

我在 vba 中有以下代码，一切正常，但我需要更改以附加所选文件夹中的所有文件（现在我必须写下所述附件的名称）。 不幸的是，我在 vba 编程方面是个菜鸟。

Sub Send_Files()

Dim OutApp As Object
Dim OutMail As Object
Dim sh As Worksheet
Dim cell As Range
Dim FileCell As Range
Dim rng As Range

With Application
    .EnableEvents = False
    .ScreenUpdating = False
End With

Set sh = Sheets("Sheet1")

Set OutApp = CreateObject("Outlook.Application")

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

    Set rng = sh.Cells(cell.Row, 1).Range("D1:Z1")

    If cell.Value Like "?*@?*.?*" And _
    Application.WorksheetFunction.CountA(rng) > 0 Then
        Set OutMail = OutApp.CreateItem(0)

        With OutMail
            .To = sh.Cells(cell.Row, 1).Value
            .CC = sh.Cells(cell.Row, 2).Value
            .Subject = "Decont UTA"
            .Body = sh.Cells(cell.Row, 3).Value

            For Each FileCell In rng.SpecialCells(xlCellTypeConstants)
                If Trim(FileCell.Value) <> "" Then
                    If Dir(FileCell.Value) <> "" Then
                        .Attachments.Add FileCell.Value
                    End If
                End If
            Next FileCell

            .Send 'Or use .Display/Send
        End With

        Set OutMail = Nothing
    End If
Next cell

Set OutApp = Nothing

With Application
    .EnableEvents = True
    .ScreenUpdating = True
End With

End Sub

Answer 1

在文件夹和子文件夹中查找特定文件的一般方法。

'******************************************************************
'* Find files in current folder and optionally in subfolders
'*
Option Explicit

Const ROOTFOLDER = "C:\Test"  'Change as desired
Const EXTENSION = "txt"       'Change as desired

Const FILES = "*." & EXTENSION

Dim g_FolderCount As Integer
Dim g_FileCount As Integer
'**********************************
'* Test code only
'*
Sub Test()
    Dim Path As String

    g_FileCount = 0
    g_FolderCount = 0
    Path = ROOTFOLDER
    GetSubFolders Path, True
    Debug.Print "Number of folders: " & g_FolderCount & ". Number of files: " & g_FileCount
End Sub
'****************************************************************
'* Recursive sub to find path and files
'*
Sub GetSubFolders(Path As String, subFolders As Boolean)
    Dim FSO As Object           'Late binding: Scripting.FileSystemObject
    Dim myFolder As Object      'Late binding: Folder
    Dim mySubFolder As Object

    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set myFolder = FSO.GetFolder(Path)
    If subFolders Then
        If myFolder.subFolders.Count <> 0 Then
            ProcessFiles Path                             'First branch (root)
            For Each mySubFolder In myFolder.subFolders
                g_FolderCount = g_FolderCount + 1
                GetSubFolders mySubFolder.Path, subFolders
            Next
        Else  'No more subfolders in Path, process files in current path
            ProcessFiles Path
        End If
    Else 'No subdirectories, process current only
       ProcessFiles Path
    End If
End Sub
'*********************************************
'* Callback from GetSubFolders
'* Process files in the found folder
'*
Sub ProcessFiles(ByVal Path As String)
    Dim theFilePattern As String
    Dim theFile As String

    Path = Path & "\"
    theFilePattern = Path & FILES
    theFile = Dir(theFilePattern)
    While theFile <> ""    'Attach file with your own code from here
        g_FileCount = g_FileCount + 1
        Debug.Print Path & theFile
        theFile = Dir()    ' Next file if any
    Wend
End Sub