Sending email from Write - code listing

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