Sub SendDocAsMail()

Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem

On Error Resume Next

'Start Outlook if it isn't running
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
    Set oOutlookApp = CreateObject("Outlook.Application")
End If

'Create a new message
Set oItem = oOutlookApp.CreateItem(olMailItem)
oItem.Subject = "Testing"
oItem.To = "nsmith@metroinsurance.com"

'Copy the open document
Selection.WholeStory
Selection.Copy
Selection.End = True

Dim finderTo
'finderTo = Selection.Find.Execute FindText:="library"
'finderTo = wdEditor.Characters

'Set the WordEditor
Dim objInsp As Outlook.Inspector
Dim wdEditor As Word.Document
Set objInsp = oItem.GetInspector
Set wdEditor = objInsp.WordEditor

Dim whateverThis As String
extractorString = ActiveDocument.Content
extractorString = extractorString.Find.ClearFormatting

'Dim firstPos As Integer
'Dim secondPost As Integer
'Dim strExtracted As String
'firstPos = 2
'firstPos = extractorString.InStr("doc")
'secondPos = extractorString.InStr("]]]")
Dim xEmail As String
Dim xSubject As String
Dim txt As String

'Extract Email Address

'txt = extractorString
'pFirst = InStr(txt, "@@((")
'pSecond = InStr(txt, "**))")
'strExtracted = Mid(txt, pFirst, pSecond)
'xEmail = strExtracted
'xEmail = Replace(xEmail, "@@((", "")
'xEmail = Replace(xEmail, "**))", "")
'whatever = Len(xEmail)


'Extract Subject Line
txt = extractorString
pFirst = InStr(txt, "{{{")
pSecond = InStr(txt, "}}}")
strExtracted = Mid(txt, pFirst, pSecond)
xSubject = strExtracted
xSubject = Replace(xSubject, "{{{", "")
xSubject = Replace(xSubject, "}}}", "")
oItem.Subject = xSubject

'Extract test Line
txt = extractorString
pFirst = InStr(txt, "[[[")
pSecond = InStr(txt, "]]]")
strExtracted = Mid(txt, pFirst, pSecond)
xTest = strExtracted
xTest = Replace(xTest, "[[[", "")
xTest = Replace(xTest, "]]]", "")
oItem.To = xTest

x = 2
'Write the intro if specified
Dim i As Integer
i = 1


'Comment the next line to leave your default signature below the document
'wdEditor.Content.Delete


'Place the current document under the intro and signature
wdEditor.Characters(i).PasteAndFormat (wdFormatOriginalFormatting)

'Display the message
oItem.Display

'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
Set objInsp = Nothing
Set wdEditor = Nothing

End Sub