AL1483
11-22-2019, 01:16 PM
Hi Guys,
Happy Friday!!! Hope everyone is doing great. I need your help with the following issue.
My current vba code sends an email with the content of this code in the body of the email and I want to change it so it sends the embedded word document I have in a hidden sheet called (Email) that has some images and text as well as text that gets filled in from the user-form. Can you please help me get this done. Here is the part of the code I'm currently using for the email.
Current email code:
strMsg = "<p>Hello Good Day</p></br>" & _ "<p>ˇWelcome!</p></br>" & _
"<p><strong>Attached you will find:</strong></p></br>" & _
"<ul><li>A welcome presentation.</li>" & _
"<li>Your welcome letter</li>" & _
"<li>Directions to you work location <SITE></li>" & _
"<li>First day Guide and Agenda. (Please bring all of this with you)</li>"
strMsg = strMsg & "<li>Bring Copies of your documents.</li></ul>"
strMsg = strMsg & "<p>Your hire date is <strong><u><HIREDATE></u></strong>. Please be on time " & _
"at the work location <SITE> (<ADDRESS>) at <strong><HIRETIME>, in <ROOM>.</strong></p></br>" & _
"<p>Be reminded if you are late your hires date maybe pushed back</p></br>" & _
"<p><strong>Notes</strong>:</p>" & _
"<ul><li>Dont forget your picture ID</li>" & _
"<li>If You have any questions please dial Ext <u>5280</u>." & _
" 24 hours a day 7 days a week</li></ul></br>" & _
"<p>Please let me know if you have any questions.</p></br>" & _
"<p>Regards.</p>" & _
"<p>" & Application.UserName & "</p>" & _
"<p><a title='MYICON' target='_blank' rel='noopener'><img src='https://www.underconsideration.com/brandnew/archives/MYICON_logo_detail.png' width='157' height='85' /></a></p>"
strMsg = Replace(strMsg, "<SITE>", strSite)
strMsg = Replace(strMsg, "<HIREDATE>", strHireDate)
strMsg = Replace(strMsg, "<ADDRESS>", strSiteAddress)
strMsg = Replace(strMsg, "<HIRETIME>", strTime)
strMsg = Replace(strMsg, "<ROOM>", strSiteRoom)
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
This part will fill in the spaces on the embedded word document in the email sheet:
With WB
.Worksheets("Email").Visible = True
.Worksheets("Email").Copy Before:=WB.Worksheets(WB.Worksheets.Count)
.Worksheets("Email").Visible = xlSheetVeryHidden
.Worksheets("Email (2)").Shapes("objWordEmail").OLEFormat.Verb 2
On Error Resume Next
Set WordDoc = GetObject(, "Word.Application").ActiveDocument
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = GetObject(, "Word.Application").ActiveDocument
End If
With WordDoc
With .Content.Find
.Text = "<HIREDATE>"
.Replacement.Text = strHireDate
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "<HIRETIME>"
.Replacement.Text = strTime
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "<ROOM>"
.Replacement.Text = strSiteRoom
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "<CONTACTEXT>"
.Replacement.Text = strContactPhoneExt
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End With
Happy Friday!!! Hope everyone is doing great. I need your help with the following issue.
My current vba code sends an email with the content of this code in the body of the email and I want to change it so it sends the embedded word document I have in a hidden sheet called (Email) that has some images and text as well as text that gets filled in from the user-form. Can you please help me get this done. Here is the part of the code I'm currently using for the email.
Current email code:
strMsg = "<p>Hello Good Day</p></br>" & _ "<p>ˇWelcome!</p></br>" & _
"<p><strong>Attached you will find:</strong></p></br>" & _
"<ul><li>A welcome presentation.</li>" & _
"<li>Your welcome letter</li>" & _
"<li>Directions to you work location <SITE></li>" & _
"<li>First day Guide and Agenda. (Please bring all of this with you)</li>"
strMsg = strMsg & "<li>Bring Copies of your documents.</li></ul>"
strMsg = strMsg & "<p>Your hire date is <strong><u><HIREDATE></u></strong>. Please be on time " & _
"at the work location <SITE> (<ADDRESS>) at <strong><HIRETIME>, in <ROOM>.</strong></p></br>" & _
"<p>Be reminded if you are late your hires date maybe pushed back</p></br>" & _
"<p><strong>Notes</strong>:</p>" & _
"<ul><li>Dont forget your picture ID</li>" & _
"<li>If You have any questions please dial Ext <u>5280</u>." & _
" 24 hours a day 7 days a week</li></ul></br>" & _
"<p>Please let me know if you have any questions.</p></br>" & _
"<p>Regards.</p>" & _
"<p>" & Application.UserName & "</p>" & _
"<p><a title='MYICON' target='_blank' rel='noopener'><img src='https://www.underconsideration.com/brandnew/archives/MYICON_logo_detail.png' width='157' height='85' /></a></p>"
strMsg = Replace(strMsg, "<SITE>", strSite)
strMsg = Replace(strMsg, "<HIREDATE>", strHireDate)
strMsg = Replace(strMsg, "<ADDRESS>", strSiteAddress)
strMsg = Replace(strMsg, "<HIRETIME>", strTime)
strMsg = Replace(strMsg, "<ROOM>", strSiteRoom)
Set olApp = GetObject("", "Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
On Error Resume Next
Set olApp = CreateObject("Outlook.Application")
On Error GoTo 0
If olApp Is Nothing Then
MsgBox "Outlook is not available!"
Exit Sub
End If
End If
This part will fill in the spaces on the embedded word document in the email sheet:
With WB
.Worksheets("Email").Visible = True
.Worksheets("Email").Copy Before:=WB.Worksheets(WB.Worksheets.Count)
.Worksheets("Email").Visible = xlSheetVeryHidden
.Worksheets("Email (2)").Shapes("objWordEmail").OLEFormat.Verb 2
On Error Resume Next
Set WordDoc = GetObject(, "Word.Application").ActiveDocument
If Err.Number <> 0 Then
Err.Clear
Set WordApp = CreateObject("Word.Application")
WordApp.Visible = False
Set WordDoc = GetObject(, "Word.Application").ActiveDocument
End If
With WordDoc
With .Content.Find
.Text = "<HIREDATE>"
.Replacement.Text = strHireDate
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "<HIRETIME>"
.Replacement.Text = strTime
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "<ROOM>"
.Replacement.Text = strSiteRoom
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
.Text = "<CONTACTEXT>"
.Replacement.Text = strContactPhoneExt
.Wrap = wdFindContinue
.Execute Replace:=wdReplaceAll
End With
End With