Как прикрепить все файлы в папке к электронной почте - код VBA - PullRequest
Новая
       13

Как прикрепить все файлы в папке к электронной почте - код VBA

0 голосов
/ 16 января 2019

У меня есть следующий код в 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

1 Ответ

0 голосов
/ 16 января 2019

Общий подход для поиска определенных файлов в папке и, возможно, во вложенных папках. 

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