Option Explicit
'Ben Clothier - http://www.rondebruin.nl/win/s1/outlook/openclose.htm
#Const LateBind = True

Const olMinimized As Long = 1
Const olMaximized As Long = 2
Const olFolderCalendar As Long = 9
Const olFolderContacts As Long = 10
Const olFolderDrafts As Long = 16
Const olFolderInbox As Long = 6
Const olFolderOutbox = 4
Const olFolderSentMail = 5
Const olFolderTasks = 13

#If LateBind Then

Public Function OutlookApp( _
       Optional WindowState As Long = olMinimized, _
       Optional Folder As Long = olFolderInbox, _
       Optional ReleaseIt As Boolean = False _
       ) As Object
Static o As Object
#Else
Public Function OutlookApp( _
       Optional WindowState As Outlook.OlWindowState = olMinimized, _
       Optional Folder As Long = olFolderInbox, _
       Optional ReleaseIt As Boolean _
       ) As Outlook.Application
Static o As Outlook.Application
#End If
    On Error GoTo ErrHandler

    Select Case True
        Case o Is Nothing, Len(o.Name) = 0
            Set o = GetObject(, "Outlook.Application")
            If o.Explorers.Count = 0 Then
InitOutlook:
                'Open inbox to prevent errors with security prompts
                o.Session.GetDefaultFolder(Folder).Display
                o.ActiveExplorer.WindowState = WindowState
            End If
        Case ReleaseIt
            Set o = Nothing
    End Select
    Set OutlookApp = o

ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case -2147352567
            'User cancelled setup, silently exit
            Set o = Nothing
        Case 429, 462
            Set o = GetOutlookApp()
            If o Is Nothing Then
                Err.Raise 429, "OutlookApp", "Outlook Application does not appear to be installed."
            Else
                Resume InitOutlook
            End If
        Case Else
            MsgBox "Error " & Err.Number & ": " & Err.Description, vbCritical, "Unexpected error"
    End Select
    Resume ExitProc
    Resume
End Function

#If LateBind Then
Private Function GetOutlookApp() As Object
#Else
Private Function GetOutlookApp() As Outlook.Application
#End If
    On Error GoTo ErrHandler
    Set GetOutlookApp = CreateObject("Outlook.Application")
ExitProc:
    Exit Function
ErrHandler:
    Select Case Err.Number
        Case Else
            'Do not raise any errors
            Set GetOutlookApp = Nothing
    End Select
    Resume ExitProc
    Resume
End Function

Sub CreateMessage()
Dim OutApp As Object
Dim olInsp As Object
Dim outMail As Object
Dim wdDoc As Document
Dim oSource As Document
Dim oRng As Range
    Set oSource = ActiveDocument 'the document with the message format
    oSource.Range.Copy
    Set OutApp = OutlookApp()
    Set outMail = OutApp.createitem(0)
    With outMail
        .to = "mlw@sierrawireless.com"
        .Subject = "Test Email"
        .BodyFormat = 2
        Set olInsp = .GetInspector
        Set wdDoc = olInsp.WordEditor
        Set oRng = wdDoc.Range
        oRng.PasteAndFormat (wdFormatOriginalFormatting)
        .Display
    End With
lbl_Exit:
    Set OutApp = Nothing
    Set olInsp = Nothing
    Set oSource = Nothing
    Set wdDoc = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub