.CreateItemFromTemplate with VBA excel but text format not
Greeting everyone.
I am trying to make Mail Merge with Excel + Outlook by using mail template i created. In template i have all text and text format with [FirstName] to get the name from excel column. Everything work fine except that the text format (font style, color, bold etc) all goes to default setting like you compose a new mail. your guidance is very much appreciate. Here is the code for VBA in excel:
Code:
Public Sub SendMailMergeExcel()
Dim olApp As Object
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim rCount As Long
Dim bXStarted As Boolean
Dim enviro As String
Dim appdata As String
Dim strPath As String
Dim strAttachPath As String
Dim SendTo As String
Dim CCTo As String
Dim strABM As String
Dim strABMPhone As String
Dim AcctMgrEmail
Dim olItem As Outlook.MailItem
Dim Recip As Outlook.Recipient
' Get Excel set up
enviro = CStr(Environ("USERPROFILE"))
appdata = CStr(Environ("appdata"))
On Error Resume Next
Set xlApp = Excel.Application
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.ActiveWorkbook
Set xlSheet = xlWB.Sheets("Sheet1")
' Process the message record
On Error Resume Next
rCount = 2
strAttachPath = enviro & "\Documents\Send\"
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bXStarted = True
End If
Do Until Trim(xlSheet.Range("A" & rCount)) = ""
strFirstname = xlSheet.Range("A" & rCount)
SendTo = xlSheet.Range("B" & rCount)
CCTo = xlSheet.Range("C" & rCount)
strSubject = xlSheet.Range("D" & rCount)
' if adding attachment
'strAttachment = strAttachPath & xlSheet.Range("E" & rCount)
strABM = xlSheet.Range("F" & rCount)
strABMPhone = xlSheet.Range("G" & rCount)
'Create Mail Item and view before sending
' Default message form
'Set olItem = olApp.CreateItem(olMailItem)
' use a Template
Set olItem = olApp.CreateItemFromTemplate(appdata & "\Microsoft\Templates\FP Mail.oft")
With olItem
.SentOnBehalfOfName = AcctMgrEmail
.To = SendTo
.CC = CCTo
.Subject = strSubject
.Body = Replace(.Body, "[FirstName]", strFirstname)
.Body = Replace(.Body, "[ABM]", strABM)
.Body = Replace(.Body, "[ABMPhone]", strABMPhone)
'if adding attachments:
'.Attachments.Add strAttachment
'.Save
.Display
'.Send
End With
rCount = rCount + 1
Loop
Set xlWB = Nothing
Set xlApp = Nothing
End Sub
(Code is not mine. I only edit some part due to error))
