This is complete code listing for the previous example. You can open the Tools/Macros/Macro Editor screen and paste the entire listing below into your macros file.
Sub SendEmail
Dim objSession, objMessage, objRecip, strEmsg, strTo, strSubject
strEmsg = ActiveDocument.Text.Mid(0, ActiveDocument.Text.Count)
strTo = GetEmailHeader(abTxt, "To:")
If Len(strTo) = 0 Then Exit Sub
strSubject = GetEmailHeader(abTxt, "Subject:")
Set objSession = CreateObject("MAPI.SESSION")
objSession.Logon "MS Exchange Settings"
Set objMessage = objSession.Outbox.Messages.Add
objMessage.Subject = strSubject
objMessage.Text = strEmsg
Set objRecip = objMessage.Recipients.Add
objRecip.Name = strTo
objRecip.Type = 1
objRecip.Resolve
objMessage.Update
objMessage.Send
objSession.Logoff
End Sub
Function GetEmailHeader(msg, str)
Dim spos, fpos, abText, slen
slen = Len(str)
spos = InStr(1, msg, str, 1)
If spos Then
fpos = InStr(spos, msg, vbCr) - 1
GetEmailHeader = Trim(Mid(msg, spos + slen, fpos - spos - slen + 1))
msg = Left(msg, spos - 1) & Mid(msg, fpos+2)
While Left(msg, 1) = vbCr
msg = Mid(msg, 2)
Wend
Else
GetEmailHeader = InputBox("Please enter text for the " & _
str & " part of the email header")
End If
End Function