[英]How to open a folder to choose which files to attach to email using Excel VBA?
[英]How to attach all files in folder to an email - vba code
我在 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
在文件夹和可选的子文件夹中查找特定文件的一般方法。
'******************************************************************
'* 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
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.