As a refinement to the send email macro we can extract the "To" and "Subject" fields from the text of a document using the following function:
Function GetEmailHeader(msg, str)
Dim spos, fpos, abText, slen
slen = Len(str)
' Find for example, To: somewhere in the document text
spos = InStr(1, msg, str, 1)
If spos Then
' If found, find the end of the line
fpos = InStr(spos, msg, vbCr) - 1
' Set the function to return the desired text
GetEmailHeader = Trim(Mid(msg, spos + slen, fpos - spos - slen + 1))
' Delete the line from the email and tidy-up excess linefeeds
msg = Left(msg, spos - 1) & Mid(msg, fpos+2)
While Left(msg, 1) = vbCr
msg = Mid(msg, 2)
Wend
Else
' Not found, so prompt user for the text
GetEmailHeader = InputBox("Please enter text for the " & _
str & " part of the email header")
End If
End Function
The function is called by replacing the lines:
strTo = "support@ability.com"
strSubject = "Send from Ability Write"
in the SendEmail subroutine with the following
strTo = GetEmailHeader(abTxt, "To:")
' Check to see if the user Cancelled the function..
If Len(strTo) = 0 Then Exit Sub
strSubject = GetEmailHeader(abTxt, "Subject:")
See the complete code listing .