Sending Document by Text Form Field

[Loss1003]

I have word 2010 document that includes form fields. I’d like to send the document into outlook and have the subject line name pulled from one of the text form fields (bookmark as Aname & PolNum). The following code works except the subject includes the wording (FORMTEXT) before the aname and PolNum. I've tried protecting and unprotecting the document to see if that helped. Thanks for your help.


Sub sendeMail()
Dim olkApp As Object
Dim strSubject As String
Dim strTo As String
Dim strBody As String
Dim strAtt As String

' Dim Temp As String
' Temp = ActiveDocument.FormFields("Text1").Result
' ActiveDocument.FormFields("Text2").Result = Temp


' strSubject = "Whatever!"
strSubject = "Quality Questionnaire" & " - " & ActiveDocument.Bookmarks("Aname").Range.Text & " - " & ActiveDocument.Bookmarks("PolNum").Range.Text
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: MKLLosscontrolQQ@markelcorp.com"
strTo = ""
If ActiveDocument.Fullname = "" Then
MsgBox "activedocument not saved, exiting"
Exit Sub
Else
If MsgBox("Activedocument NOT saved, Proceed?", vbYesNo, "Error") <> vbYes Then Exit Sub
End If
strAtt = ActiveDocument.Fullname

Set olkApp = CreateObject("outlook.application")
With olkApp.createitem(0)
.to = strTo
.Subject = strSubject
.body = strBody
.attachments.Add strAtt
'.send
.Display
End With
Set olkApp = Nothing
End Sub

[Loss1003]

Please close I figured this out by using

Dim Temp As String
Temp = ActiveDocument.FormFields("Aname").Result

etc.

[gmayor]

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