Hi Experts,
The below VBA code helps me to send multiple mail in excel via outlook application. Is it possible to use the same code to send multiple mails via Zimbra Application.
Option Explicit
Sub Preview()
Call SetRange
SendEmail False
lbl_Exit:
Exit Sub
End Sub
Sub NoPreview()
Call SetRange
SendEmail True
lbl_Exit:
Exit Sub
End Sub
Sub SendEmail(Optional bNoPreview As Boolean)
Dim iRec As Long
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim wdRng As Object
Dim rng As Range
Dim StrBody As String
Dim StrBody1 As String
Dim i As Long
Dim Subj As String
Dim FilePath As String
Dim EmailTo As String
Dim CCto As String
With Range("MergeData")
For i = 2 To .Rows.Count
Range("MergeRecord") = i - 1
Set rng = Nothing
Subj = .Cells(i, "A").Value & " - " & .Cells(i, "D").Value & " - " & .Cells(i, "N")
FilePath = .Cells(i, "I").Value & .Cells(i, "A").Value & ".pdf"
EmailTo = .Cells(i, "H").Value
'CCto = .Cells(i, "D").Value
Application.DisplayAlerts = False
Set rng = Sheets("Sheet2").Range("A1:E2").SpecialCells(xlCellTypeVisible)
rng.Copy
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
StrBody = "Dear Sir," & vbCr & vbCr & _
"We have the outstanding in our system. Could you please provide your agreement on it." & vbCr & vbCr
StrBody1 = vbCr & "If you have any queries in regards to the above, please do not hesitate to contact me." & vbCr & vbCr & _
"Look forward for your reply." & vbCr & vbCr & "Many thanks in advance." & vbCr
On Error Resume Next
With OutMail
.To = EmailTo
.CC = CCto
.BCC = ""
.Subject = Subj
.BodyFormat = 2
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set wdRng = wdDoc.Range(0, 0)
wdRng.Text = StrBody
wdRng.collapse 0
wdRng.Paste
wdRng.collapse 0
wdRng.Text = StrBody1
If FileExists(FilePath) Then
.Attachments.Add FilePath
Else
MsgBox "The file " & FilePath & " does not exist at that location."
End If
.Display
If bNoPreview Then
.Send
End If
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
'Sheets("RAW_Data").Cells(1, "A").Value = "Outlook sent Time, Dynamic msg preview count = " & i
Next i
End With
Cleanup:
Set OutApp = Nothing
Set OutMail = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set wdRng = Nothing
Set rng = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub SetRange()
Dim xlSheet As Worksheet
Dim LastRow As Long, LastCol As Long
Dim rng As Range
Set xlSheet = Sheets("RAW_Data")
With xlSheet
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Application.Calculation = xlManual
Names("MergeData").Delete
Names.Add Name:="MergeData", _
RefersToR1C1:="=RAW_Data!R1C1:R" & LastRow & "C" & LastCol
Application.Calculation = xlAutomatic
End With
Set xlSheet = Nothing
End Sub
Public Function FileExists(ByVal Filename As String) As Boolean
Dim lngAttr As Long
On Error GoTo NoFile
lngAttr = GetAttr(Filename)
If (lngAttr And vbDirectory) vbDirectory Then
FileExists = True
End If
NoFile:
Exit Function
End Function
Option Explicit
Sub Preview()
Call SetRange
SendEmail False
lbl_Exit:
Exit Sub
End Sub
Sub NoPreview()
Call SetRange
SendEmail True
lbl_Exit:
Exit Sub
End Sub
Sub SendEmail(Optional bNoPreview As Boolean)
Dim iRec As Long
Dim OutApp As Object
Dim OutMail As Object
Dim olInsp As Object
Dim wdDoc As Object
Dim wdRng As Object
Dim rng As Range
Dim StrBody As String
Dim StrBody1 As String
Dim i As Long
Dim Subj As String
Dim FilePath As String
Dim EmailTo As String
Dim CCto As String
With Range("MergeData")
For i = 2 To .Rows.Count
Range("MergeRecord") = i - 1
Set rng = Nothing
Subj = .Cells(i, "A").Value & " - " & .Cells(i, "D").Value & " - " & .Cells(i, "N")
FilePath = .Cells(i, "I").Value & .Cells(i, "A").Value & ".pdf"
EmailTo = .Cells(i, "H").Value
'CCto = .Cells(i, "D").Value
Application.DisplayAlerts = False
Set rng = Sheets("Sheet2").Range("A1:E2").SpecialCells(xlCellTypeVisible)
rng.Copy
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
StrBody = "Dear Sir," & vbCr & vbCr & _
"We have the outstanding in our system. Could you please provide your agreement on it." & vbCr & vbCr
StrBody1 = vbCr & "If you have any queries in regards to the above, please do not hesitate to contact me." & vbCr & vbCr & _
"Look forward for your reply." & vbCr & vbCr & "Many thanks in advance." & vbCr
On Error Resume Next
With OutMail
.To = EmailTo
.CC = CCto
.BCC = ""
.Subject = Subj
.BodyFormat = 2
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set wdRng = wdDoc.Range(0, 0)
wdRng.Text = StrBody
wdRng.collapse 0
wdRng.Paste
wdRng.collapse 0
wdRng.Text = StrBody1
If FileExists(FilePath) Then
.Attachments.Add FilePath
Else
MsgBox "The file " & FilePath & " does not exist at that location."
End If
.Display
If bNoPreview Then
.Send
End If
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Application.DisplayAlerts = True
'Sheets("RAW_Data").Cells(1, "A").Value = "Outlook sent Time, Dynamic msg preview count = " & i
Next i
End With
Cleanup:
Set OutApp = Nothing
Set OutMail = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set wdRng = Nothing
Set rng = Nothing
lbl_Exit:
Exit Sub
End Sub
Sub SetRange()
Dim xlSheet As Worksheet
Dim LastRow As Long, LastCol As Long
Dim rng As Range
Set xlSheet = Sheets("RAW_Data")
With xlSheet
LastCol = .Cells(2, .Columns.Count).End(xlToLeft).Column
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
Application.Calculation = xlManual
Names("MergeData").Delete
Names.Add Name:="MergeData", _
RefersToR1C1:="=RAW_Data!R1C1:R" & LastRow & "C" & LastCol
Application.Calculation = xlAutomatic
End With
Set xlSheet = Nothing
End Sub
Public Function FileExists(ByVal Filename As String) As Boolean
Dim lngAttr As Long
On Error GoTo NoFile
lngAttr = GetAttr(Filename)
If (lngAttr And vbDirectory) vbDirectory Then
FileExists = True
End If
NoFile:
Exit Function
End Function