Make a word document from range of cell and send as attachment from outlook

[missrutele]

I have this code to send PDF files but now I need to send word document instead of PDF, could someone help to adjust the code:

Sub PDFXX()

    Dim SaveAsStr As String


    'SaveAsStr = ActiveWorkbook.Path & "\" & ActiveSheet.Range("J1").Value

    SaveAsStr = ActiveSheet.Range("J1").Value


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _

        Filename:=SaveAsStr & ".pdf", _

        OpenAfterPublish:=False

End Sub


Sub AttachActiveSheetPDFXX()

  Dim IsCreated As Boolean

  Dim i As Long

  Dim PdfFile As String, Title As String

  Dim OutlApp As Object


'SaveAsStr = ActiveWorkbook.Path & "\" & ActiveSheet.Range("J1").Value

SaveAsStr = ActiveSheet.Range("J1").Value


    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, _

        Filename:=SaveAsStr & ".pdf", _

        OpenAfterPublish:=False


  ' Not sure for what the Title is

  Title = Range("K15")


   ' Define PDF filename

  PdfFile = ActiveWorkbook.FullName

     i = InStrRev(PdfFile, ".")

  If i > 1 Then PdfFile = Left(PdfFile, i - 1)

    PdfFile = PdfFile & " " & Range("J1") & ".pdf"

 

  ' Export activesheet as PDF

  With ActiveSheet

    .ExportAsFixedFormat Type:=xlTypePDF, Filename:=PdfFile, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False

  End With


  ' Use already open Outlook if possible

  On Error Resume Next

  Set OutlApp = GetObject(, "Outlook.Application")

  If Err Then

    Set OutlApp = CreateObject("Outlook.Application")

    IsCreated = True

  End If

  OutlApp.Visible = True

  On Error GoTo 0


  ' Prepare e-mail with PDF attachment

  With OutlApp.CreateItem(0)

 

    ' Prepare e-mail

    .Subject = Range("K17")

    .To = Range("K5") ' <-- Put email of the recipient here

    .CC = Range("K6") ' <-- Put email of 'copy to' recipient here

    .Body = Range("K8") & vbLf & vbLf _

          & Range("K9") & vbLf & vbLf _

          & Range("K10") & vbLf & vbLf _

          & Range("K11") & vbLf & vbLf _

          & Range("K12") & vbLf & vbLf _

          & Range("K13") & vbLf _

          & Application.UserName & vbLf & vbLf

    .Attachments.Add PdfFile

 

    ' Try to send

    On Error Resume Next

    .Send

    Application.Visible = True

    If Err Then

      MsgBox "E-mail was not sent", vbExclamation

    Else

      MsgBox "E-mail successfully sent", vbInformation

    End If

    On Error GoTo 0

 

  End With


  ' Delete PDF file

  Kill PdfFile


  ' Quit Outlook if it was created by this code

  If IsCreated Then OutlApp.Quit


End Sub

 

[Worf]

This is the first part, creating the Word document.

Sub CopyToWord()
Dim wdApp As Word.Application, wDoc As Word.Document, ws As Worksheet
Set wdApp = New Word.Application
Set wDoc = wdApp.Documents.Add
Set ws = ActiveSheet
ws.UsedRange.Copy               ' source data
wDoc.Paragraphs(wDoc.Paragraphs.Count).Range.InsertParagraphAfter
wDoc.Paragraphs(wDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = 0
wDoc.Paragraphs(wDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wDoc.Paragraphs(wDoc.Paragraphs.Count).Range
    .InsertParagraphBefore
    .Collapse Direction:=wdCollapseEnd
    .InsertBreak Type:=wdPageBreak
End With
Set ws = Nothing
With wdApp.ActiveWindow
    If .View.SplitSpecial = wdPaneNone Then
        .ActivePane.View.Type = wdNormalView
    Else
        .View.Type = wdNormalView
    End If
End With
Set wDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
End Sub

 

[Worf]

This one attaches a Word document.

Sub AttachActiveSheet()     ' run me
Dim IsCreated As Boolean, i As Long, OutlApp As Object, wn$
wn = "c:\users\public\wdoc.docx"
CopyToWord wn
On Error Resume Next
Set OutlApp = GetObject(, "Outlook.Application")
If Err Then
    Set OutlApp = CreateObject("Outlook.Application")
    IsCreated = True
End If
OutlApp.Visible = True
On Error GoTo 0
With OutlApp.CreateItem(0)
    .Subject = Range("K17")
    .To = Range("K5") ' <-- Put email of the recipient here
    .CC = Range("K6") ' <-- Put email of 'copy to' recipient here
    .Body = Range("K8") & vbLf & Range("K9") & vbLf & Range("K10") & vbLf & vbLf & _
    [K11] & vbLf & Range("K12") & vbLf & Range("K13") & vbLf & Application.UserName & vbLf
    .Attachments.Add wn
    .Display
    Application.Visible = True
    If Err Then
        MsgBox "E-mail was not sent", vbExclamation
    Else
        MsgBox "E-mail successfully created", vbInformation
    End If
    On Error GoTo 0
End With
If IsCreated Then OutlApp.Quit
End Sub
 
Sub CopyToWord(fn$)
Dim wdApp As Word.Application, wDoc As Word.Document, ws As Worksheet
Set wdApp = New Word.Application
Set wDoc = wdApp.Documents.Add
Set ws = ActiveSheet
ws.UsedRange.Copy               ' source data
wDoc.Paragraphs(wDoc.Paragraphs.Count).Range.InsertParagraphAfter
wDoc.Paragraphs(wDoc.Paragraphs.Count).Range.Paste
Application.CutCopyMode = 0
wDoc.Paragraphs(wDoc.Paragraphs.Count).Range.InsertParagraphAfter
With wDoc.Paragraphs(wDoc.Paragraphs.Count).Range
    .InsertParagraphBefore
    .Collapse Direction:=wdCollapseEnd
    .InsertBreak Type:=wdPageBreak
End With
Set ws = Nothing
With wdApp.ActiveWindow
    If .View.SplitSpecial = wdPaneNone Then
        .ActivePane.View.Type = wdNormalView
    Else
        .View.Type = wdNormalView
    End If
End With
wDoc.SaveAs2 fn
Set wDoc = Nothing
wdApp.Visible = True
Set wdApp = Nothing
End Sub