[英]Send Email with Multiple Attachments
我对 VBA 很陌生。 I trying to have a Button that will generate an Outlook HTML formatted Email to send to the designated email address (designated by cell) and be able to attach multiple files located in the same folder as the workbook. 使用 FileDialog 框,我希望出现的初始文件夹与当前工作簿的文件夹位置相同,以减少搜索文件的次数。
以下是我到目前为止所拥有的。 我想不通的是让 FileDialog 框在 Workbook 原始文件夹中打开。
Private Sub CommandButton1_Click()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C14").Value
.Subject = Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " Tile Estimate"
.HTMLBody = Range("B14").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the" & Range("B6").Value & " " & Range("B7").Value & " - " & Range("B9").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton3_Click()
End Sub
更新,这是我最终使用的
Sub Email_1()
Dim xStrFile As String
Dim xFilePath As String
Dim xFileDlg As FileDialog
Dim xFileDlgItem As Variant
Dim xOutApp As Outlook.Application
Dim xMailOut As Outlook.MailItem
Application.ScreenUpdating = False
Set xOutApp = CreateObject("Outlook.Application")
Set xMailOut = xOutApp.CreateItem(olMailItem)
Set xFileDlg = Application.FileDialog(msoFileDialogFilePicker)
xFileDlg.Filters.Clear
xFileDlg.Filters.Add "pdf files", "*.pdf"
xFileDlg.AllowMultiSelect = True
xFileDlg.InitialFileName = ThisWorkbook.Path
If xFileDlg.Show = -1 Then
With xMailOut
.Display
.To = Range("C13").Value
.Subject = Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " Tile Estimate"
.HTMLBody = "<p style='font-family:calibri;font-size:12.0pt'>" & Range("B13").Value & "," & "<br/>" & vbCrLf & "Here is our tile estimate for the " & Range("B5").Value & " " & Range("B6").Value & " - " & Range("B8").Value & " project. Please respond to this email to confirm that you have received the proposal." & .HTMLBody
For Each xFileDlgItem In xFileDlg.SelectedItems
.Attachments.Add xFileDlgItem
Next xFileDlgItem
.Display
End With
End If
Set xMailOut = Nothing
Set xOutApp = Nothing
Application.ScreenUpdating = True
End Sub
声明:本站的技术帖子网页,遵循CC BY-SA 4.0协议,如果您需要转载,请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.