Refining the send email macro

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 .