Hi,
I am using the macro file where it is possible to send bulk mails along with multiple attachement.
I am getting error while sending multiple attachments while it is working fine if i am attaching only one file.
Somebody Pl help.
Regatds,
Amandeep Singh
Option Explicit
Code:Function SendMessage(strTo As String, Optional strCC As String, Optional strBCC As String, Optional strSubject As String, Optional strMessage As String, Optional rngToCopy As Range, Optional strAttachmentPath As String, Optional blnShowEmailBodyWithoutSending As Boolean = False, Optional blnSignature As Boolean)
Dim objOutlook As Object 'Outlook.Application
Dim objOutlookMsg As Object 'Outlook.MailItem
Dim objOutlookRecip As Object 'Outlook.Recipient
Dim objOutlookAttach As Object 'Outlook.Attachment
Dim lngLoop As Long
Dim strSignature As String
If Trim(strTo) & Trim(strCC) & Trim(strBCC) = "" Then
MsgBox "Please provide a mailing address!", vbInformation + vbOKOnly, "Missing mail information"
Exit Function
End If
'Create the Outlook session.
On Error Resume Next
Set objOutlook = GetObject(, "Outlook.Application." & Val(Application.Version))
Err.Clear: On Error GoTo -1: On Error GoTo 0
If objOutlook Is Nothing Then
Set objOutlook = CreateObject("Outlook.Application." & Val(Application.Version))
End If
'Create the message.
Set objOutlookMsg = objOutlook.CreateItem(0)
With objOutlookMsg
'Add the To recipient(s) to the message.
For lngLoop = LBound(Split(strTo, ";")) To UBound(Split(strTo, ";"))
If Trim(Split(strTo, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strTo, ";")(lngLoop)))
objOutlookRecip.Type = 1 'olTO
End If
Next lngLoop
'Add the CC recipient(s) to the message.
For lngLoop = LBound(Split(strCC, ";")) To UBound(Split(strCC, ";"))
If Trim(Split(strCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strCC, ";")(lngLoop)))
objOutlookRecip.Type = 2 'olCC
End If
Next lngLoop
'Add the BCC recipient(s) to the message.
For lngLoop = LBound(Split(strBCC, ";")) To UBound(Split(strBCC, ";"))
If Trim(Split(strBCC, ";")(lngLoop)) <> "" Then
Set objOutlookRecip = .Recipients.Add(Trim(Split(strBCC, ";")(lngLoop)))
objOutlookRecip.Type = 3 'olBCC
End If
Next lngLoop
'Set the Subject, Body, and Importance of the message.
If strSubject = "" Then
strSubject = "This is an Automation test with Microsoft Outlook"
End If
.Subject = strSubject
If strMessage = "" Then
strMessage = "This is the body of the message." & vbCrLf & vbCrLf
End If
.Importance = 2 'High importance
If Not strMessage = "" Then
.Body = strMessage & vbCrLf & vbCrLf
End If
If Not rngToCopy Is Nothing Then
.HTMLBody = .Body & RangetoHTML(rngToCopy)
End If
'Add attachments to the message.
For lngLoop = LBound(Split(strAttachmentPath, "|")) To UBound(Split(strAttachmentPath, "|"))
If Not strAttachmentPath = "" Then
If Len(Dir(Trim(Split(strAttachmentPath, "|")(lngLoop)))) <> 0 Then
Set objOutlookAttach = .Attachments.Add(Trim(Split(strAttachmentPath, "|")(lngLoop)))
Else
MsgBox "Unable to find the specified attachment '" & Trim(Split(strAttachmentPath, "|")(lngLoop)) & "'. Sending mail anyway."
End If
End If
Next lngLoop
If blnSignature Then
'Win XP
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\Application Data\Microsoft\Signatures\" & Dir(strSignature)
If Dir(strSignature) = "" Then
'Win 7
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\*.htm"
strSignature = Environ("USERPROFILE") & "\AppData\Roaming\Microsoft\Signatures\" & Dir(strSignature)
End If
End If
If Dir(strSignature) <> "" Then
strSignature = GetBoiler(strSignature)
Else
strSignature = ""
End If
'MsgBox .htmlbody
.HTMLBody = .HTMLBody & strSignature
'Resolve each Recipient's name.
For Each objOutlookRecip In .Recipients
objOutlookRecip.Resolve
Next
'Should we display the message before sending?
If blnShowEmailBodyWithoutSending Then
.Display
Else
.Display
.Save
.Send
End If
End With
Set objOutlook = Nothing
Set objOutlookMsg = Nothing
Set objOutlookAttach = Nothing
Set objOutlookRecip = Nothing
End Function
Function RangetoHTML(rng As Range)
'Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim strTempFile As String
Dim wbkTemp As Workbook
strTempFile = Environ$("temp") & Application.PathSeparator & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
'Copy the range and create a workbook to receive the data.
rng.Copy
Set wbkTemp = Workbooks.Add(1)
With wbkTemp.Sheets(1)
With .Cells(1)
.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues, , False, False
.PasteSpecial xlPasteFormats, , False, False
.Select
End With
Application.CutCopyMode = False
On Error Resume Next
.DrawingObjects.Visible = True
.DrawingObjects.Delete
Err.Clear: On Error GoTo 0
End With
'Publish the sheet to an .htm file.
With wbkTemp.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=strTempFile, _
Sheet:=wbkTemp.Sheets(1).Name, _
Source:=wbkTemp.Sheets(1).UsedRange.Address, _
HtmlType:=xlHtmlStatic)
.Publish (True)
End With
'Read all data from the .htm file into the RangetoHTML subroutine.
RangetoHTML = GetBoiler(strTempFile)
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
'Close wbkTemp
wbkTemp.Close savechanges:=False
'Delete the htm file.
Kill strTempFile
Set wbkTemp = Nothing
End Function
Function GetBoiler(ByVal strFile As String) As String
'May not be supported in MAC
Dim objFSO As Object
Dim objTextStream As Object
On Error Resume Next
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextStream = objFSO.GetFile(strFile).OpenAsTextStream(1, -2)
GetBoiler = objTextStream.ReadAll
objTextStream.Close
Set objFSO = Nothing
Set objTextStream = Nothing
End Function
Not working. Same Error.
What have you used in Range E2?
Sir,
There is one folder in D Drive "TEST"
In this folder there are 2 files:
Manoj.xlsx
Aman.xlsx
in e2 i m putting manoj.xlsx,aman.xlsx (without any space)
And what's the result of the formula in F2?
Made some modification to the code above.. try it now.
Thanks Sir,
Now its working fine. One more requirement.
Whatever i am writing in message box, it comes in one line.
Can we make the changes in macro so that "Dear Sir" reflect in 1st line. after that it takes enter then the message in next line and so on..
Why don't you enter a line between in the cell itself? Use ALT+ENTER to enter a line.
I have already made the ALT + Enter but it is not working.
It is showing in single line only.