通过一封或多封电子邮件发送文件,每封电子邮件最多包含 10 个附件
Sending files via one or more emails with at most 10 attachments each
我正在尝试将文件夹中的所有文件作为电子邮件附件发送,每封邮件最多 10 个附件。
所以我将以下宏放在一起,将所有文件附加到电子邮件中并发送,然后移动文件,效果很好
但现在我尝试每封邮件发送 10 个文件,然后再发送文件夹中的下 10 个文件,重复直到发送完所有文件。
我试过几种方法都没有用。
如何在 10 个附件后终止 Do While loop
并将代码移动到下一个语句?
attchFile = Dir(attchPath & "*.*")
'// Loop to attch
Do While Len(attchFile) > 0
.Attachments.Add attchPath & attchFile
sExtension = Right(attchFile, _
Len(attchFile) - InStrRev(attchFile, Chr(46)))
'// Check if the file exists and save with unique name
oldName = attchFile
NewName = FileNameUnique(MovePath, attchFile, sExtension)
'// Move the files.
Name attchPath & oldName As MovePath & NewName
attchFile = Dir
Loop
'// Cancell email if no files to send
If .Attachments.Count = 0 Then
.Close 0
.Delete
Else
如果您需要完整的代码,请告诉我。
编辑
这是完整的代码。
Option Explicit
Sub SendFiles()
Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olRecip As Outlook.Recipient
Dim attchPath As String
Dim MovePath As String
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim olRng As Object
Dim attchFile As String
Dim sExtension As String
Dim NewName As String
Dim oldName As String
'// Attachments Path.
attchPath = "C:\Files\"
'// Move Path.
MovePath = "C:\Completed\"
' On Error GoTo lbl_Exit
'// Set Outlook.
Set olApp = Outlook.Application
'// Create the message.
Set olMsg = olApp.CreateItem(olMailItem)
With olMsg
.Display '// This line must be retained
attchFile = Dir(attchPath & "*.*")
'// Loop to attch
Do While Len(attchFile) > 0
.Attachments.Add attchPath & attchFile
sExtension = Right(attchFile, _
Len(attchFile) - InStrRev(attchFile, Chr(46)))
'// Check if the file exists and save with unique name
oldName = attchFile
NewName = FileNameUnique(MovePath, attchFile, sExtension)
'// Move the files.
Name attchPath & oldName As MovePath & NewName
attchFile = Dir
Loop
'// Cancell email if no files to send
If .Attachments.Count = 0 Then
'MsgBox "There are no reports to attach.", vbInformation
.Close 0
.Delete
Else
'// Add the To recipient(s)
Set olRecip = .Recipients.Add("Email")
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olTo
'// Add the CC recipient(s)
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olCC
'// Set the Subject, Body, and Importance of the message.
.Subject = "Reports - " & Format(Now, "Long Date")
.Importance = olImportanceHigh '// High importance
.BodyFormat = olFormatHTML
'// Edit the message body.
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
'// Set message body (to retain the signature)
Set olRng = wdDoc.Range(0, 0)
'// add the text to message body
olRng.text = "Attached files has been Completed, Thank you" & vbCrLf & vbCrLf
'// Resolve each Recipient's name.
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If
Next
'.DeleteAfterSubmit = True
.Send '//This line optional
End If
End With
lbl_Exit:
Set olMsg = Nothing
Set olApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set olRng = Nothing
Exit Sub
End Sub
'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
'// If the same file name exist in Completed Path folder then add (1)
Private Function FileNameUnique(sPath As String, _
FileName As String, _
sExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(FileName) - (Len(sExtension) + 1)
FileName = Left(FileName, lngName)
Do While FileExists(sPath & FileName & Chr(46) & sExtension) = True
FileName = Left(FileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = FileName & Chr(46) & sExtension
lbl_Exit:
Exit Function
End Function
尝试将邮件创建代码放在它自己的循环中。添加最多 10 个附件后,让内部附加循环中止,只有当没有剩余文件要添加时,外循环才会中止。
以下代码修改您的方法,紧接在 Set olApp = Outlook.Application
行下方
attchFile = Dir(attchPath & "*.*")
'// Cancel email if no files to send
If Len(attchFile) = 0 Then
MsgBox "There are no reports to attach.", vbInformation
Else
Do While Len(attchFile) > 0
'// Create the message.
Set olMsg = olApp.CreateItem(olMailItem)
With olMsg
.Display '// This line must be retained
'// Loop to attach files
Do While Len(attchFile) > 0 And .Attachments.Count < 10
.Attachments.Add attchPath & attchFile
sExtension = Right(attchFile, _
Len(attchFile) - InStrRev(attchFile, Chr(46)))
'// Check if the file exists and save with unique name
oldName = attchFile
NewName = FileNameUnique(MovePath, attchFile, sExtension)
'// Move the files.
Name attchPath & oldName As MovePath & NewName
'// Look for the next attachment to be added
attchFile = Dir(attchPath & "*.*")
Loop
'// Add the To recipient(s)
Set olRecip = .Recipients.Add("Email")
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olTo
'// Add the CC recipient(s)
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olCC
'// Set the Subject, Body, and Importance of the message.
.Subject = "Reports - " & Format(Now, "Long Date")
.Importance = olImportanceHigh '// High importance
.BodyFormat = olFormatHTML
'// Edit the message body.
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
'// Set message body (to retain the signature)
Set olRng = wdDoc.Range(0, 0)
'// add the text to message body
olRng.Text = "Attached files has been Completed, Thank you" & vbCrLf & vbCrLf
'// Resolve each Recipient's name.
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If
Next
'.DeleteAfterSubmit = True
.Send
End With
Loop
End If
我正在尝试将文件夹中的所有文件作为电子邮件附件发送,每封邮件最多 10 个附件。
所以我将以下宏放在一起,将所有文件附加到电子邮件中并发送,然后移动文件,效果很好
但现在我尝试每封邮件发送 10 个文件,然后再发送文件夹中的下 10 个文件,重复直到发送完所有文件。
我试过几种方法都没有用。
如何在 10 个附件后终止 Do While loop
并将代码移动到下一个语句?
attchFile = Dir(attchPath & "*.*")
'// Loop to attch
Do While Len(attchFile) > 0
.Attachments.Add attchPath & attchFile
sExtension = Right(attchFile, _
Len(attchFile) - InStrRev(attchFile, Chr(46)))
'// Check if the file exists and save with unique name
oldName = attchFile
NewName = FileNameUnique(MovePath, attchFile, sExtension)
'// Move the files.
Name attchPath & oldName As MovePath & NewName
attchFile = Dir
Loop
'// Cancell email if no files to send
If .Attachments.Count = 0 Then
.Close 0
.Delete
Else
如果您需要完整的代码,请告诉我。
编辑
这是完整的代码。
Option Explicit
Sub SendFiles()
Dim olApp As Outlook.Application
Dim olMsg As Outlook.MailItem
Dim olRecip As Outlook.Recipient
Dim attchPath As String
Dim MovePath As String
Dim olInsp As Outlook.Inspector
Dim wdDoc As Object
Dim olRng As Object
Dim attchFile As String
Dim sExtension As String
Dim NewName As String
Dim oldName As String
'// Attachments Path.
attchPath = "C:\Files\"
'// Move Path.
MovePath = "C:\Completed\"
' On Error GoTo lbl_Exit
'// Set Outlook.
Set olApp = Outlook.Application
'// Create the message.
Set olMsg = olApp.CreateItem(olMailItem)
With olMsg
.Display '// This line must be retained
attchFile = Dir(attchPath & "*.*")
'// Loop to attch
Do While Len(attchFile) > 0
.Attachments.Add attchPath & attchFile
sExtension = Right(attchFile, _
Len(attchFile) - InStrRev(attchFile, Chr(46)))
'// Check if the file exists and save with unique name
oldName = attchFile
NewName = FileNameUnique(MovePath, attchFile, sExtension)
'// Move the files.
Name attchPath & oldName As MovePath & NewName
attchFile = Dir
Loop
'// Cancell email if no files to send
If .Attachments.Count = 0 Then
'MsgBox "There are no reports to attach.", vbInformation
.Close 0
.Delete
Else
'// Add the To recipient(s)
Set olRecip = .Recipients.Add("Email")
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olTo
'// Add the CC recipient(s)
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olCC
'// Set the Subject, Body, and Importance of the message.
.Subject = "Reports - " & Format(Now, "Long Date")
.Importance = olImportanceHigh '// High importance
.BodyFormat = olFormatHTML
'// Edit the message body.
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
'// Set message body (to retain the signature)
Set olRng = wdDoc.Range(0, 0)
'// add the text to message body
olRng.text = "Attached files has been Completed, Thank you" & vbCrLf & vbCrLf
'// Resolve each Recipient's name.
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If
Next
'.DeleteAfterSubmit = True
.Send '//This line optional
End If
End With
lbl_Exit:
Set olMsg = Nothing
Set olApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set olRng = Nothing
Exit Sub
End Sub
'// Check if the file exists
Private Function FileExists(FullName As String) As Boolean
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
If FSO.FileExists(FullName) Then
FileExists = True
Else
FileExists = False
End If
lbl_Exit:
Exit Function
End Function
'// If the same file name exist in Completed Path folder then add (1)
Private Function FileNameUnique(sPath As String, _
FileName As String, _
sExtension As String) As String
Dim lngF As Long
Dim lngName As Long
lngF = 1
lngName = Len(FileName) - (Len(sExtension) + 1)
FileName = Left(FileName, lngName)
Do While FileExists(sPath & FileName & Chr(46) & sExtension) = True
FileName = Left(FileName, lngName) & "(" & lngF & ")"
lngF = lngF + 1
Loop
FileNameUnique = FileName & Chr(46) & sExtension
lbl_Exit:
Exit Function
End Function
尝试将邮件创建代码放在它自己的循环中。添加最多 10 个附件后,让内部附加循环中止,只有当没有剩余文件要添加时,外循环才会中止。
以下代码修改您的方法,紧接在 Set olApp = Outlook.Application
attchFile = Dir(attchPath & "*.*")
'// Cancel email if no files to send
If Len(attchFile) = 0 Then
MsgBox "There are no reports to attach.", vbInformation
Else
Do While Len(attchFile) > 0
'// Create the message.
Set olMsg = olApp.CreateItem(olMailItem)
With olMsg
.Display '// This line must be retained
'// Loop to attach files
Do While Len(attchFile) > 0 And .Attachments.Count < 10
.Attachments.Add attchPath & attchFile
sExtension = Right(attchFile, _
Len(attchFile) - InStrRev(attchFile, Chr(46)))
'// Check if the file exists and save with unique name
oldName = attchFile
NewName = FileNameUnique(MovePath, attchFile, sExtension)
'// Move the files.
Name attchPath & oldName As MovePath & NewName
'// Look for the next attachment to be added
attchFile = Dir(attchPath & "*.*")
Loop
'// Add the To recipient(s)
Set olRecip = .Recipients.Add("Email")
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olTo
'// Add the CC recipient(s)
Set olRecip = .Recipients.Add("Email")
olRecip.Type = olCC
'// Set the Subject, Body, and Importance of the message.
.Subject = "Reports - " & Format(Now, "Long Date")
.Importance = olImportanceHigh '// High importance
.BodyFormat = olFormatHTML
'// Edit the message body.
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
'// Set message body (to retain the signature)
Set olRng = wdDoc.Range(0, 0)
'// add the text to message body
olRng.Text = "Attached files has been Completed, Thank you" & vbCrLf & vbCrLf
'// Resolve each Recipient's name.
For Each olRecip In .Recipients
olRecip.Resolve
If Not olRecip.Resolve Then
olMsg.Display
End If
Next
'.DeleteAfterSubmit = True
.Send
End With
Loop
End If