You need to introduce some error checking and you presumably want to hyperlink the e-mail address?
Option Explicit
Sub sendeMail()
Dim olApp As Object
Dim olInsp As Object
Dim olItem As Object
Dim wdDoc As Document
Dim oRng As Range
Dim strTo As String
Dim strSubject As String
Dim strName As String
Dim strPolNum As String
Dim strBody As String
Dim strAtt As String
Dim oFld As FormField
Dim bFld As Boolean
Dim bStarted As Boolean
Dim oLink As Hyperlink
Const strLink = "mailto:MKLLosscontrolQQ@markelcorp.com?subject=Subject%20Questionnaire" ' the link address
Const strLinkText = "MKLLosscontrolQQ@markelcorp.com" ' the link display text
If Documents.Count = 0 Then
MsgBox "No document open!"
GoTo lbl_Exit
End If
If ActiveDocument.FormFields.Count = 0 Then
MsgBox "There are no form fields in the active document!"
GoTo lbl_Exit
End If
For Each oFld In ActiveDocument.FormFields
If oFld.Name = "Text1" Then
strTo = oFld.Result
bFld = True
Exit For
End If
Next oFld
If bFld = False Then
MsgBox "The field 'Text1' is not present in the document."
GoTo lbl_Exit
End If
If strTo = "" Then
MsgBox "Enter a value in the field 'Text1' and run the macro again."
GoTo lbl_Exit
End If
For Each oFld In ActiveDocument.FormFields
If oFld.Name = "Aname" Then
strName = oFld.Result
bFld = True
Exit For
End If
Next oFld
If bFld = False Then
MsgBox "The field 'Aname' is not present in the document."
GoTo lbl_Exit
End If
If strName = "" Then
MsgBox "Enter a value in the field 'Aname' and run the macro again."
GoTo lbl_Exit
End If
For Each oFld In ActiveDocument.FormFields
If oFld.Name = "PolNum" Then
strPolNum = oFld.Result
bFld = True
Exit For
End If
Next oFld
If bFld = False Then
MsgBox "The field 'PolNum' is not present in the document."
GoTo lbl_Exit
End If
If strPolNum = "" Then
MsgBox "Enter a value in the field 'PolNum' and run the macro again."
GoTo lbl_Exit
End If
If ActiveDocument.Path = "" Then
MsgBox "Activedocument not saved, exiting"
Exit Sub
Else
ActiveDocument.Save
End If
strAtt = ActiveDocument.FullName
strSubject = "Quality Questionnaire" & " - " & strName & " - " & strPolNum
strBody = "In striving to provide the best information possible to our associates, we ask you to please take five minutes to fill out this questionnaire and Email the completed form to: "
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set olApp = CreateObject("Outlook.Application")
bStarted = True
End If
On Error GoTo err_Handler
Set olItem = olApp.createitem(0)
With olItem
.to = strTo
.Subject = strSubject
Set olInsp = .GetInspector
Set wdDoc = olInsp.WordEditor
Set oRng = wdDoc.Range(0, 0)
Set oLink = wdDoc.Hyperlinks.Add(Anchor:=oRng, _
Address:=strLink, _
SubAddress:="", _
ScreenTip:="", _
TextToDisplay:=strLinkText)
oRng.Collapse 1
oRng.Text = strBody
.attachments.Add strAtt
.Display 'This line is required
'.send 'Restore after testing
End With
lbl_Exit:
Set olApp = Nothing
Set olInsp = Nothing
Set wdDoc = Nothing
Set oLink = Nothing
Set oRng = Nothing
Exit Sub
err_Handler:
MsgBox Err.Number & vbCr & Err.Description
Err.Clear
GoTo lbl_Exit
End Sub