将 While 语句中的多个附件添加到电子邮件参数
Add multiple attachments from While statement to email argument
我正在使用遗留代码并尝试将他们的电子邮件代码从一堆多个电子邮件代码更新为单个调用。在我 运行 进入 While Wend 附件声明之前，我一直很成功。
我正在使用以下 Public Sub 来调用这些电子邮件。
Public Sub SendEmail(ByVal recipient As String, ByVal subject As String, ByVal bodyText As String, SendDisplay As Boolean, Optional ByVal carboncopy As String, Optional attachment0 As String, Optional attachment1 As String, Optional attachement2 As String, Optional attachement3 As String, Optional attachement4 As String)
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Shell "outlook.exe", vbNormalFocus
Else
AppActivate objOutlook.ActiveExplorer.Caption
End If
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
With OutApp
.Session.Logon
Set OutMail = .CreateItem(olMailItem)
End With
With OutMail
.To = recipient
If carboncopy <> "" Then
.CC = carboncopy
End If
.subject = subject
.Body = bodyText
If attachment0 <> "" Then
.Attachments.Add attachment0
End If
If attachment1 <> "" Then
.Attachments.Add attachment1
End If
If attachment2 <> "" Then
.Attachments.Add attachment2
End If
If attachment3 <> "" Then
.Attachments.Add attachment3
End If
If attachment4 <> "" Then
.Attachments.Add attachment4
End If
If SendDisplay Then
.Display True
Else
.Send
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
我遇到问题的代码片段是使用 While Wend 循环附加文件夹中所有文件的代码。
With OutMail
While Len(strFileName) > 0
.Attachments.Add (strDir & strFileName)
strFileName = Dir
Wend
.subject = (MySub)
.Body = strbody
.BodyFormat = olFormatPlain '1
.Display True
End With
我正在尝试将上面的 With 转换为
SendEmail "", (MySub), strbody, True, , ???
我的问题是从这个 While Wend 循环中获取这些附件的最佳方法是什么？
代码位于用户窗体中，所有文件都是在窗体从 ComboBox 加载和导出选定作品时创建的sheets，然后按下导出按钮作为 PDF 到文件夹。
有没有办法使用 While 将文件添加到 SendEmail 子附件的参数中？有没有办法将这些文件添加到文件夹中的参数中？
感谢您的宝贵时间。
编辑更清晰的解释
初始化用户窗体时，它会将所有可见的作品sheet加载到 ComboBox1 中。从 ComboBox1 中选择一个项目并按下 CommandButton1 以仅导出所选 sheet.
Private Sub CommandButton1_Click()
If (ComboBox1.Text = "") Then
MsgBox ("Select a sheet to Export to PDF.")
Exit Sub
End If
Set rngRange = Worksheets("DM").Range("D10")
If ComboBox1.Value = "TR" Then
setname = "Treatment Report"
ElseIf ComboBox1.Value = "DM" Then
setname = "Data Master Cover"
ElseIf ComboBox1.Value = "JHA" Then
setname = "JHA"
ElseIf ComboBox1.Value = "SIGN" Then
setname = "Safety Meeting Sign In Sheet"
Else
setname = Worksheets("DM").Range("B41")
End If
bolSelected = True
strDirname = Worksheets("DM").Range("B41") & " " & Worksheets("DM").Range("D9") & " " & rngRange.Value
strFileName = Worksheets("DM").Range("B41") & " " & Worksheets("DM").Range("D9") & " " & rngRange.Value & " " & setname
strDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & strDirname
If Dir(strDir, vbDirectory) = vbNullString Then MkDir strDir
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=strDir & "\" & strFileName, openafterpublish:=False, ignoreprintareas:=False
MsgBox "File exported to My Documents.", , "EXPORT COMPLETE"
Worksheets("DM").Select
End Sub
当导出用户需要的所有 sheet 时（可能是一个或两个或三个或全部），用户按下命令按钮 2，要求通过电子邮件发送 sheet他们导出了，如果是，它将 运行 通过此电子邮件表单。
Private Sub CommandButton2_Click()
If bolSelected = True Then
If MsgBox("Do you want to email exported files now?", vbYesNo, "EMAIL ITEMS") = vbYes Then
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Shell "outlook.exe", vbNormalFocus
Else
AppActivate objOutlook.ActiveExplorer.Caption
End If
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
With OutApp
.Session.Logon
Set OutMail = .CreateItem(olMailItem) '0
End With
strDirname = strDirname & "\"
strDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & strDirname
strFileName = Dir(strDir)
strbody = "This file was sent by " & vbNewLine & vbNewLine & _
Application.UserName & vbNewLine & _
"on " & Format(Date, "MMMM/dd/yyyy")
With OutMail
While Len(strFileName) > 0
.Attachments.Add (strDir & strFileName)
strFileName = Dir
Wend
.Subject = (MySub)
.Body = strbody
.BodyFormat = olFormatPlain '1
.Display True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Me
Else
Unload Me
End If
Else
Unload Me
End If
End Sub
我创建了一个所有电子邮件代码都使用的名为“Post_Office”的新模块“SendEmail”，此工作簿散布了上述代码中的 6 个。 SendEmail 在 6 个中的 5 个上工作，就好像有附件一样，它们将永远存在。
这是唯一一个电子邮件附件可能存在也可能不存在的用户表单。
有没有办法让从这个用户表单创建的文件附加到电子邮件，就像上面的 While Wend 语句一样？
这可以通过ParamArrayVBA,ParamArray attachments()来实现，像这样：
Option Explicit
Public Sub SendEmail(ByVal recipient As String, ByVal subject As String, ByVal bodyText As String, SendDisplay As Boolean, ByVal carboncopy As String, _
ParamArray attachments())
Dim x
Dim OutMail As Object, objOutlook As Object
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Shell "outlook.exe", vbNormalFocus
Set objOutlook = GetObject(, "Outlook.Application")
Else
AppActivate objOutlook.ActiveExplorer.Caption
End If
If objOutlook Is Nothing Then Set objOutlook = CreateObject("Outlook.Application")
With objOutlook
.Session.Logon
Set OutMail = .CreateItem(olMailItem)
End With
With OutMail
.To = recipient
If carboncopy <> "" Then
.CC = carboncopy
End If
.subject = subject
.Body = bodyText
For Each x In attachments
If x <> "" Then
.attachments.Add x
End If
Next
If SendDisplay Then
.Display True
Else
.Send
End If
End With
Set OutMail = Nothing
Set objOutlook = Nothing
End Sub
'
' SendEmail "", (MySub), strbody, True, , ???
'
Sub doSendmail()
SendEmail "johndoe@example.com", "Test", "Hello body", True, "", "filename", "filename2", "filename3", "filename4"
End Sub
我们用这个循环替换添加附件():
For Each x In attachments
If x <> "" Then
.attachments.Add x
End If
Next
我最终使用数组将我需要的数据获取到 paramarray 参数中。
strbody = "This file was sent by " & vbNewLine & vbNewLine & _
Application.UserName & vbNewLine & _
"on " & Format(Date, "MMMM/dd/yyyy")
Dim MyFile As String
Dim Counter As Long
Dim SEattachArray() As String
ReDim SEattachArray(6)
MyFile = Dir$(strDir)
Do While MyFile <> ""
SEattachArray(Counter) = (strDir & MyFile)
MyFile = Dir$
Counter = Counter + 1
Loop
SendEmail "", "", strbody, True, "", SEattachArray(0), SEattachArray(1), SEattachArray(2), SEattachArray(3), SEattachArray(4), SEattachArray(5)
SendEmail 将首先填充现有文件，然后是不存在的文件，允许 X 忽略来自 paramarray 参数的空值，允许参数传递并打开 Outlook 发送发送电子邮件 window 并附上文件。
For Each X In attachments
If X <> "" Then
.attachments.Add X
End If
Next
我正在使用遗留代码并尝试将他们的电子邮件代码从一堆多个电子邮件代码更新为单个调用。在我 运行 进入 While Wend 附件声明之前，我一直很成功。
我正在使用以下 Public Sub 来调用这些电子邮件。
Public Sub SendEmail(ByVal recipient As String, ByVal subject As String, ByVal bodyText As String, SendDisplay As Boolean, Optional ByVal carboncopy As String, Optional attachment0 As String, Optional attachment1 As String, Optional attachement2 As String, Optional attachement3 As String, Optional attachement4 As String)
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Shell "outlook.exe", vbNormalFocus
Else
AppActivate objOutlook.ActiveExplorer.Caption
End If
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
With OutApp
.Session.Logon
Set OutMail = .CreateItem(olMailItem)
End With
With OutMail
.To = recipient
If carboncopy <> "" Then
.CC = carboncopy
End If
.subject = subject
.Body = bodyText
If attachment0 <> "" Then
.Attachments.Add attachment0
End If
If attachment1 <> "" Then
.Attachments.Add attachment1
End If
If attachment2 <> "" Then
.Attachments.Add attachment2
End If
If attachment3 <> "" Then
.Attachments.Add attachment3
End If
If attachment4 <> "" Then
.Attachments.Add attachment4
End If
If SendDisplay Then
.Display True
Else
.Send
End If
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
我遇到问题的代码片段是使用 While Wend 循环附加文件夹中所有文件的代码。
With OutMail
While Len(strFileName) > 0
.Attachments.Add (strDir & strFileName)
strFileName = Dir
Wend
.subject = (MySub)
.Body = strbody
.BodyFormat = olFormatPlain '1
.Display True
End With
我正在尝试将上面的 With 转换为
SendEmail "", (MySub), strbody, True, , ???
我的问题是从这个 While Wend 循环中获取这些附件的最佳方法是什么？
代码位于用户窗体中，所有文件都是在窗体从 ComboBox 加载和导出选定作品时创建的sheets，然后按下导出按钮作为 PDF 到文件夹。
有没有办法使用 While 将文件添加到 SendEmail 子附件的参数中？有没有办法将这些文件添加到文件夹中的参数中？
感谢您的宝贵时间。
编辑更清晰的解释
初始化用户窗体时，它会将所有可见的作品sheet加载到 ComboBox1 中。从 ComboBox1 中选择一个项目并按下 CommandButton1 以仅导出所选 sheet.
Private Sub CommandButton1_Click()
If (ComboBox1.Text = "") Then
MsgBox ("Select a sheet to Export to PDF.")
Exit Sub
End If
Set rngRange = Worksheets("DM").Range("D10")
If ComboBox1.Value = "TR" Then
setname = "Treatment Report"
ElseIf ComboBox1.Value = "DM" Then
setname = "Data Master Cover"
ElseIf ComboBox1.Value = "JHA" Then
setname = "JHA"
ElseIf ComboBox1.Value = "SIGN" Then
setname = "Safety Meeting Sign In Sheet"
Else
setname = Worksheets("DM").Range("B41")
End If
bolSelected = True
strDirname = Worksheets("DM").Range("B41") & " " & Worksheets("DM").Range("D9") & " " & rngRange.Value
strFileName = Worksheets("DM").Range("B41") & " " & Worksheets("DM").Range("D9") & " " & rngRange.Value & " " & setname
strDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & strDirname
If Dir(strDir, vbDirectory) = vbNullString Then MkDir strDir
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, FileName:=strDir & "\" & strFileName, openafterpublish:=False, ignoreprintareas:=False
MsgBox "File exported to My Documents.", , "EXPORT COMPLETE"
Worksheets("DM").Select
End Sub
当导出用户需要的所有 sheet 时（可能是一个或两个或三个或全部），用户按下命令按钮 2，要求通过电子邮件发送 sheet他们导出了，如果是，它将 运行 通过此电子邮件表单。
Private Sub CommandButton2_Click()
If bolSelected = True Then
If MsgBox("Do you want to email exported files now?", vbYesNo, "EMAIL ITEMS") = vbYes Then
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Shell "outlook.exe", vbNormalFocus
Else
AppActivate objOutlook.ActiveExplorer.Caption
End If
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then Set OutApp = CreateObject("Outlook.Application")
With OutApp
.Session.Logon
Set OutMail = .CreateItem(olMailItem) '0
End With
strDirname = strDirname & "\"
strDir = CreateObject("WScript.Shell").SpecialFolders("MyDocuments") & "\" & strDirname
strFileName = Dir(strDir)
strbody = "This file was sent by " & vbNewLine & vbNewLine & _
Application.UserName & vbNewLine & _
"on " & Format(Date, "MMMM/dd/yyyy")
With OutMail
While Len(strFileName) > 0
.Attachments.Add (strDir & strFileName)
strFileName = Dir
Wend
.Subject = (MySub)
.Body = strbody
.BodyFormat = olFormatPlain '1
.Display True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Unload Me
Else
Unload Me
End If
Else
Unload Me
End If
End Sub
我创建了一个所有电子邮件代码都使用的名为“Post_Office”的新模块“SendEmail”，此工作簿散布了上述代码中的 6 个。 SendEmail 在 6 个中的 5 个上工作，就好像有附件一样，它们将永远存在。
这是唯一一个电子邮件附件可能存在也可能不存在的用户表单。
有没有办法让从这个用户表单创建的文件附加到电子邮件，就像上面的 While Wend 语句一样？
这可以通过ParamArrayVBA,ParamArray attachments()来实现，像这样：
Option Explicit
Public Sub SendEmail(ByVal recipient As String, ByVal subject As String, ByVal bodyText As String, SendDisplay As Boolean, ByVal carboncopy As String, _
ParamArray attachments())
Dim x
Dim OutMail As Object, objOutlook As Object
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application")
If Err.Number = 429 Then
Shell "outlook.exe", vbNormalFocus
Set objOutlook = GetObject(, "Outlook.Application")
Else
AppActivate objOutlook.ActiveExplorer.Caption
End If
If objOutlook Is Nothing Then Set objOutlook = CreateObject("Outlook.Application")
With objOutlook
.Session.Logon
Set OutMail = .CreateItem(olMailItem)
End With
With OutMail
.To = recipient
If carboncopy <> "" Then
.CC = carboncopy
End If
.subject = subject
.Body = bodyText
For Each x In attachments
If x <> "" Then
.attachments.Add x
End If
Next
If SendDisplay Then
.Display True
Else
.Send
End If
End With
Set OutMail = Nothing
Set objOutlook = Nothing
End Sub
'
' SendEmail "", (MySub), strbody, True, , ???
'
Sub doSendmail()
SendEmail "johndoe@example.com", "Test", "Hello body", True, "", "filename", "filename2", "filename3", "filename4"
End Sub
我们用这个循环替换添加附件():
For Each x In attachments
If x <> "" Then
.attachments.Add x
End If
Next
我最终使用数组将我需要的数据获取到 paramarray 参数中。
strbody = "This file was sent by " & vbNewLine & vbNewLine & _
Application.UserName & vbNewLine & _
"on " & Format(Date, "MMMM/dd/yyyy")
Dim MyFile As String
Dim Counter As Long
Dim SEattachArray() As String
ReDim SEattachArray(6)
MyFile = Dir$(strDir)
Do While MyFile <> ""
SEattachArray(Counter) = (strDir & MyFile)
MyFile = Dir$
Counter = Counter + 1
Loop
SendEmail "", "", strbody, True, "", SEattachArray(0), SEattachArray(1), SEattachArray(2), SEattachArray(3), SEattachArray(4), SEattachArray(5)
SendEmail 将首先填充现有文件，然后是不存在的文件，允许 X 忽略来自 paramarray 参数的空值，允许参数传递并打开 Outlook 发送发送电子邮件 window 并附上文件。
For Each X In attachments
If X <> "" Then
.attachments.Add X
End If
Next