Private Sub CommandButton1_Click()
    Dim oSection As Section
    Dim r As Range
    Dim TempDoc As Document
    Dim FirstPara As String
    
    'Print Document
    Shapes(1).Visible = msoFalse
    ActiveDocument.PrintOut Background:=False
    Shapes(1).Visible = msoTrue
     
    'Change Readonly Doc to a Temp Document
    For Each oSection In ActiveDocument.Sections
        Set r = oSection.Range
        r.End = r.End - 1
        Set TempDoc = Documents.Add
    With TempDoc
    
    'Change Temp Documents Page Layout to match Original
    With Selection.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientPortrait
        .TopMargin = InchesToPoints(0.5)
        .BottomMargin = InchesToPoints(0.5)
        .LeftMargin = InchesToPoints(0.5)
        .RightMargin = InchesToPoints(0.5)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .PageWidth = InchesToPoints(8.5)
        .PageHeight = InchesToPoints(11)
        .FirstPageTray = wdPrinterDefaultBin
        .OtherPagesTray = wdPrinterDefaultBin
        .SectionStart = wdSectionNewPage
        .OddAndEvenPagesHeaderFooter = False
        .DifferentFirstPageHeaderFooter = False
        .VerticalAlignment = wdAlignVerticalTop
        .SuppressEndnotes = False
        .MirrorMargins = False
        .TwoPagesOnOne = False
        .BookFoldPrinting = False
        .BookFoldRevPrinting = False
        .BookFoldPrintingSheets = 1
        .GutterPos = wdGutterPosLeft
    End With
    
    'Ask then create folder if not created
    Dim rspCreate
    If Dir("E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\", vbDirectory) = "" Then
      rspCreate = MsgBox("Directory doesn't exist, do you wish to create it?", vbYesNo)
        If rspCreate = vbYes Then
            MkDir "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\"
        End If
    End If
      
      'Set it so that the first paragraph is the name of document
            ActiveDocument.Paragraphs(1).Range.FormattedText = r
            FirstPara = r.Paragraphs(1).Range.FormattedText
            FirstPara = Left(FirstPara, Len(FirstPara) - 1)
            
      'save document
            ChangeFileOpenDirectory "E:\Documents and Settings\" & Environ("username") & "\Desktop\EMS\"
            .SaveAs FileName:=FirstPara & ".docx"
    'Print and email documents
    Dim noSession As Object, noDatabase As Object, noDocument As Object
    Dim obAttachment As Object, EmbedObject As Object
    Dim stSubject As Variant, stAttachment As String
    Dim vaRecipient As Variant
   
     'Email address where file is sent to.
    vaRecipient = "email@myemail.com"
     'Get the message from the user.
    stAttachment = ActiveDocument.FullName
     'Instantiate the Lotus Notes COM's Objects.
    Set noSession = CreateObject("Notes.NotesSession")
    Set noDatabase = noSession.GETDATABASE("", "")
     'If Lotus Notes is not open then open the mail-part of it.
    If noDatabase.IsOpen = False Then noDatabase.OPENMAIL
     'Create the e-mail and the attachment.
    Set noDocument = noDatabase.CreateDocument
    Set obAttachment = noDocument.CreateRichTextItem("stAttachment")
    Set EmbedObject = obAttachment.EmbedObject(EMBED_ATTACHMENT, "", stAttachment)
    
     'Add values to the created e-mail main properties.
    With noDocument
        .Form = "Memo"
        .SendTo = vaRecipient
        .Subject = ActiveDocument.Name
        .Body = "Attached in this email is the EMS forum"
        .SaveMessageOnSend = True
    End With
    
     'Send the e-mail instantly.
    With noDocument
        .PostedDate = Now()
        .Send 0, vaRecipient
    End With
   
    'End message to users saying process was sucessful
    MsgBox "Document was emailed and printed sucessfully"
    'Release objects from the memory.
    Set EmbedObject = Nothing
    Set obAttachment = Nothing
    Set noDocument = Nothing
    Set noDatabase = Nothing
    Set noSession = Nothing
    
    
    .Close
    
    End With
        Set r = Nothing
        Set TempDoc = Nothing
    Next
End Sub