Add content of word document text control fields to email with command button

[Neal]

Private Sub CommandButton21_Click()
Dim OL As Object
Dim EmailItem As Object
Dim Doc As Document
Dim Temp As String

Application.ScreenUpdating = False
Set OL = CreateObject("Outlook.Application")
Set EmailItem = OL.CreateItem(olMailItem)
Set Doc = ActiveDocument

Doc.Save
With EmailItem
.Subject = "Report Request"
.Body = "Hello Robert and Lisa." & vbCrLf & _
"I'm writing to request that reports be run on the provider and time period listed below." & vbCrLf & _
.To = "emailaddress"
.Send
End With

Application.ScreenUpdating = True
Set Doc = Nothing
Set OL = Nothing
Set EmailItem = Nothing

End Sub

[Neal]

How do I get a third line within the body text to be the content of text boxes "ProviderName", "NPINumber" and "DateRange" please?

[gmayor]

The best way to do this is to use the Outlook document inspector to access the message body and then the process is much like programming in Word VBA. However in order to do this, it is necessary to open Outlook correctly and your code won't do that. Use instead the function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm to open Outlook, which the code below calls.



Private Sub CommandButton21_Click()
'Graham Mayor - http://www.gmayor.com - Last updated - 15 Jun 2017
'Requires code function from http://www.rondebruin.nl/win/s1/outlook/openclose.htm
Dim OL As Object
Dim olInsp As Object
Dim wdDoc As Document
Dim oRng As Range
Dim EmailItem As Object
Dim Doc As Document
Dim oCC As ContentControl
Dim sProvider As String, sNPI As String, sDateRng As String

Application.ScreenUpdating = False
Set OL = OutlookApp()
Set Doc = ActiveDocument
Set oCC = Doc.SelectContentControlsByTitle("ProviderName").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Enter Provider"
oCC.Range.Select
GoTo lbl_exit
End If
sProvider = oCC.Range.Text

Set oCC = Doc.SelectContentControlsByTitle("NPINumber").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Enter NPI Number"
oCC.Range.Select
GoTo lbl_exit
End If
sNPI = oCC.Range.Text

Set oCC = Doc.SelectContentControlsByTitle("DateRange").Item(1)
If oCC.ShowingPlaceholderText Then
MsgBox "Enter Date Range"
oCC.Range.Select
GoTo lbl_exit
End If
sDateRng = oCC.Range.Text

Set EmailItem = OL.CreateItem(0)
Doc.Save
With EmailItem
.To = "emailaddress"
.Subject = "Report Request"
.BodyFormat = 2
Set olInsp = .GetInspector
.Display 'do not delete this line
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range
oRng.Collapse 1
oRng.Text = "Hello Robert and Lisa." & vbCrLf & _
"I'm writing to request that reports be run on the provider and time period listed below." & vbCrLf
oRng.Collapse 0
oRng.Text = sProvider & Chr(32) & sNPI & Chr(32) & sDateRng
'.Send ';Restore after testing
End With
lbl_exit:
Application.ScreenUpdating = True
Set Doc = Nothing
Set wdDoc = Nothing
Set oCC = Nothing
Set oRng = Nothing
Set olInsp = Nothing
Set OL = Nothing
Set EmailItem = Nothing
Exit Sub
End Sub

[Neal]

Thank you Mr. Mayor.

Where do I place this code please? Within the above code. And, do I simply replace 'Call NameOfYourMailMacro with CommandButton21 ? Is that name of my macro? Obviously I'm very new at this.

Sub TestOutlookIsOpen()
Dim oOutlook As Object

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
MsgBox "Outlook is not open, open Outlook and try again"
Else
'Call NameOfYourMailMacro
End If
End Sub

[gmayor]

You picked the wrong macro. The one you want is further down the page. It needs to go in a new module - ideally on its own - in the same template as the command button. It is then called from the macro I posted earlier to access Outlook, whether it is open or closed initially.

CommandButton21 was the macro name associated with the command button that you used in your initial message i.e. the code I posted earlier is the code for the button. Change that name to that of the button if necessary.



Option Explicit
'http://www.rondebruin.nl/win/s1/outlook/openclose.htm
#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderCalendar As Long = 9
Const olFolderContacts As Long = 10
Const olFolderDrafts As Long = 16
Const olFolderInbox As Long = 6
Const olFolderOutbox = 4
Const olFolderSentMail = 5
Const olFolderTasks = 13

#If LateBind Then

Public Function OutlookApp( _
Optional WindowState As Long = olMinimized, _
Optional Folder As Long = olFolderInbox, _
Optional ReleaseIt As Boolean = False _
) As Object
Static o As Object
#Else
Public Function OutlookApp( _
Optional WindowState As Outlook.OlWindowState = olMinimized, _
Optional Folder As Long = olFolderInbox, _
Optional ReleaseIt As Boolean _
) As Outlook.Application
Static o As Outlook.Application
#End If
On Error GoTo ErrHandler

Select Case True
Case o Is Nothing, Len(o.Name) = 0
Set o = GetObject(, "Outlook.Application")
If o.Explorers.Count = 0 Then
InitOutlook:
'Open inbox to prevent errors with security prompts
o.Session.GetDefaultFolder(Folder).Display
o.ActiveExplorer.WindowState = WindowState
End If
Case ReleaseIt
Set o = Nothing
End Select
Set OutlookApp = o

ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case -2147352567
'User cancelled setup, silently exit
Set o = Nothing
Case 429, 462
Set o = GetOutlookApp()
If o Is Nothing Then
Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
Else
Resume InitOutlook
End If
Case Else
MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
End Select
Resume ExitProc
Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
On Error GoTo ErrHandler
Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
Exit Function
ErrHandler:
Select Case Err.Number
Case Else
'Do not raise any errors
Set GetOutlookApp = Nothing
End Select
Resume ExitProc
Resume
End Function