This code sends a Word Doc

[Eric Penfold]

The code sends a word doc email but the text in the word doc is blurry how could improve the text quality?

Option Explicit
Sub SendDailyMailEmail()

    Dim wb     As Workbook
    Dim ws     As Worksheet
    Dim Tbl    As Range
    Dim LRow   As Long
    Dim EmailApp As Object, EmailItem As Object
    Dim Pic    As Picture
    Dim Shape1 As shape, Shape2 As shape
    Dim MyShp  As shape
    Dim WordDoc
   
    Set EmailApp = CreateObject("Outlook.Application")
    Set EmailItem = EmailApp.CreateItem(0)
    Set wb = Workbooks("MyPersonal.xlsb")
    Set ws = wb.Sheets("DailyMail")
    LRow = ws.Cells(Rows.Count, 1).End(xlUp).Row
    Set Tbl = ws.Range("A1:Q" & LRow)
   
    ws.Activate
    Tbl.Copy
    Set Pic = ws.Pictures.Paste
   
    Pic.Select
   
    Pic.Cut
   
    With EmailItem
        .to = ""
        .Subject = "Drainfast Daily Mail" & " " & Format(Date, "dd-mm-yy")
        .Display
        Set WordDoc = EmailItem.GetInspector.WordEditor
        With WordDoc.Range
            .InsertParagraphafter
            .PasteAndFormat 13
            .Application.Selection.TypeText Text:=""
            .Application.Selection.HomeKey unit:=5, Extend:=1
            .Application.Selection.EndKey unit:=6
            .Hyperlinks.Add Anchor:=.Application.Selection.Range, Address:= _
                             "https://app.smartsheet.com/b/form/05bee75bfa6a47b7b5c5cff74e64dc3d", SubAddress:="", ScreenTip:="", TextToDisplay:="Brainstorm Suggestions"
            .Application.Selection.TypeText Text:=" - "
            .Hyperlinks.Add Anchor:=.Application.Selection.Range, Address:= _
                             "\\somepath\filename.xlsx", SubAddress:="", ScreenTip:="", TextToDisplay:="Product Ideas"
           
            .Application.Selection.HomeKey unit:=5, Extend:=1
            .Application.Selection.ParagraphFormat.Alignment = 1
            .InsertParagraphafter
            .InsertParagraphafter
            .InsertAfter "Kind Regards,"
        End With
    End With
   
    On Error GoTo 0
   
    Set EmailItem = Nothing
    Set EmailApp = Nothing
   
End Sub

 

[Eric Penfold]

Thanks very helpful
But with this it`s very good but i need all the text and text position to be same as excel also need the pictures to come across including the graph. Is this possible?

 

[NdNoviceHlp]

I don't think the linked post will help if U have pictures and charts. You will need to stick with the picture approach and resize the pic. You can trial this code which adds a one cell table to the doc, pastes the pic to the doc then resizes the table (and pic) to fit the doc. You will need to change the wb and sheet name and the Set Word doc part as this is my test version which seems to work OK. HTH. Dave

Sub test()
Dim ws As Worksheet, Lrow As Long, Tbl As Range, PFWdapp As Object, WordDoc As Object
Dim TblWdth As Double, wb As Workbook
'*******change to suit
Set wb = ThisWorkbook
Set ws = wb.Sheets("Sheet1")


Lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set Tbl = ws.Range("A1:Q" & Lrow)
Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture

'open Word application
On Error Resume Next
Set PFWdapp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set PFWdapp = CreateObject("Word.Application")
End If
PFWdapp.Visible = True

'add document and insert 1 cell table
'*********change this to editor
Set WordDoc = PFWdapp.Documents.Add

With WordDoc.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With WordDoc
.Tables.Add PFWdapp.Selection.Range, NumRows:=1, NumColumns:=1
End With
'paste pic of range
With WordDoc.Tables(1).Cell(1, 1).Range
.PasteSpecial DataType:=3
End With
'format table
With WordDoc.Tables(1)
.AutoFormat Format:=16, applyborders:=False
.AutoFitBehavior (0)
.Columns.Width = TblWdth
End With
End Sub

 

[Eric Penfold]

 

[Eric Penfold]

As you can see above this will work but i need the whole of the excel sheet to be on 1 page please.

 

[NdNoviceHlp]

So, is this actually an XL table (when you click on it, does the name box indicate that it is a list object)? Is this made up of cells? Is there merged cells? Is the "image" attached to the range? Have you set the range right? It seems to test OK for me? Dave

 

[Eric Penfold]

The worksheet has no table and it`s made up of some merged cells and a Graph plus some pictures attached to the range. The range is correct.

 

[Eric Penfold]

This is my attempt to fit the range into word document?. Can`t get the shape height or width to show any values.

With WordDoc.PageSetup
        .LockAspectRatio = True
        shapewidth = .Width
        shapeheight = .Height
        If shapewidth / maxwidth > .Height / maxheight Then
            .Width = Round(maxwidth)
            shapeheight = .Height
            .Left = Round(0.75 * 72)
            .Top = Round(1.2 * 72) - Round((maxheight - WordDoc.Height) / 2)
        Else
            .Height = Round(maxheight)
            shapewidth = .Width
            .Left = Round((maxwidth + 72 - WordDoc.Width) / 2)
            .Top = Round(1.2 * 72)
        End If

 

[NdNoviceHlp]

Can you post a wb with just the range on 1 sheet? I don't see any maxwidth or maxheight values above? Dave

 

[Eric Penfold]

Can you post a wb with just the range on 1 sheet? I don't see any maxwidth or maxheight values above? Dave

maxwidth = 5.7 * 72
maxheight = 9 * 72

 

[NdNoviceHlp]

Hi aka Eric. You can trial this as it seems to work. It uses a chart to create an image file and then inserts the image file to a table in the Word doc and then resizes the image. HTH. Dave

Sub test()
Dim ws As Worksheet, Lrow As Long, Tbl As Range, PFWdapp As Object, WordDoc As Object
Dim TblWdth As Double, wb As Workbook, WrdPic As Object
'*******change to suit
Set wb = ThisWorkbook
Set ws = wb.Sheets("Dailymail")
Lrow = ws.Cells(Rows.Count, 1).End(xlUp).Row
Set Tbl = ws.Range("A1:Q" & Lrow)

Call CreateJpg("DailyMail", Tbl)

'open Word application
On Error Resume Next
Set PFWdapp = GetObject(, "word.application")
If Err.Number <> 0 Then
On Error GoTo 0
Set PFWdapp = CreateObject("Word.Application")
End If
PFWdapp.Visible = True

'add document and insert 1 cell table
'*********change this to editor
Set WordDoc = PFWdapp.Documents.Add

With WordDoc.PageSetup
TblWdth = .PageWidth - .LeftMargin - .RightMargin - .Gutter
End With
With WordDoc
.Tables.Add PFWdapp.Selection.Range, NumRows:=1, NumColumns:=1
End With
'paste pic of range
Set WrdPic = WordDoc.Tables(1).Cell(1, 1).Range.InlineShapes.AddPicture _
 (Filename:=ThisWorkbook.Path & "\DrainFast.jpg", LinkToFile:=False, SaveWithDocument:=True)
'adjust to suit
WrdPic.ScaleHeight = 38
WrdPic.ScaleWidth = 46

'format table
'???Not sure if needed???
With WordDoc.Tables(1)
.AutoFormat Format:=16, applyborders:=False
.AutoFitBehavior (0)
.Columns.Width = TblWdth
End With

Set WrdPic = Nothing
Kill ThisWorkbook.Path & "\DrainFast.jpg"
End Sub

Public Sub CreateJpg(SheetName As String, xRgAddrss As Range)
'creates temp JPG file of range (xRgAddrss) by creating temp chart
'To operate:  Call CreateJpg("Sheet1", Sheets("Sheet1").Range("A1:H8"))
'adjust sheet name and range to suit
Dim xRgPic As Range
Worksheets(SheetName).Activate
Set xRgPic = xRgAddrss
xRgPic.CopyPicture
With Sheets(SheetName).ChartObjects.Add(xRgAddrss.Left, xRgAddrss.Top, xRgAddrss.Width, xRgAddrss.Height)
.Activate
.Chart.Paste
.Chart.Export ThisWorkbook.Path & "\DrainFast.jpg", "jpg"
End With
Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
End Sub

Call Test to operate