Sub Send_As_Mail_Attachment()
'Graham Mayor = http://www.gmayor.com
'Send the document as an attachment _
  in an Outlook Email message
'Requires the code from - http://www.rondebruin.nl/win/s1/outlook/openclose.htm
'to either retrieve an open instance of Outlook or open Outlook if it is closed.
Dim bStarted As Boolean
Dim OlApp As Object
Dim oItem As Object
Dim oDoc As Document
Dim strName As String
Dim strDocName As String
Dim strPath As String
Dim intPos As Integer
Dim iFormat As Long
    Set oDoc = ActiveDocument
    'Prompt the user to save the document
    On Error GoTo Err_Handler:
    oDoc.Save
    strDocName = oDoc.Name
    iFormat = MsgBox("Send as PDF format?", vbYesNoCancel)
    If iFormat = 2 Then GoTo lbl_Exit
    If iFormat = 7 Then strDocName = oDoc.FullName: strName = oDoc.Name
    If iFormat = 6 Then
        'Get the document name and path
        strPath = oDoc.path & "\"
        intPos = InStrRev(strDocName, ".")
        strDocName = Left(strDocName, intPos - 1)
        strName = strDocName & ".pdf"
        strDocName = strPath & strDocName & ".pdf"

        'And save the document as PDF
        oDoc.ExportAsFixedFormat OutputFileName:=strDocName, _
                                 ExportFormat:=wdExportFormatPDF, _
                                 OpenAfterExport:=False, _
                                 OptimizeFor:=wdExportOptimizeForPrint, _
                                 Range:=wdExportAllDocument, From:=1, To:=1, _
                                 Item:=wdExportDocumentContent, _
                                 IncludeDocProps:=True, _
                                 KeepIRM:=True, _
                                 CreateBookmarks:=wdExportCreateHeadingBookmarks, _
                                 DocStructureTags:=True, _
                                 BitmapMissingFonts:=True, _
                                 UseISO19005_1:=False

        'Now close the document without saving as we have finished with it
        oDoc.Close 0
    End If
    'Get Outlook if it's running
    Set OlApp = OutlookApp()
    On Error GoTo 0
    'Create a new mailitem
    Set oItem = OlApp.CreateItem(0)

    With oItem
        .Subject = strName
        .attachments.Add strDocName
        .Display
    End With

lbl_Exit:
    Set oItem = Nothing
    Set OlApp = Nothing
    Exit Sub
Err_Handler:
    Err.Clear
    GoTo lbl_Exit
End Sub