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

 

[NdNoviceHlp]

Set Tbl = ws.Range("A1:Q" & LRow)
ws.Activate
Tbl.Copy
Set Pic = ws.Pictures.Paste
Pic.Select
Pic.Cut
With WordDoc.Range
.InsertParagraphafter
.PasteasPicture

 

[NdNoviceHlp]

The problem is with your copy and paste formatting. Is it a real table (list object when you select it)? You could also trial reference the ws list object instead of the range. HTH. Dave

Set Tbl = ws.Range("A1:Q" & LRow)
'ws.Activate
    Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
'    Set Pic = ws.Pictures.Paste
'  Pic.Select
'Pic.Cut
With WordDoc.Range
            .InsertParagraphafter
            .PasteSpecial DataType:=3

ps. grrr.... missed the edit

 

[Eric Penfold]

Do you mean change the spreadsheet to a excel table then copy & paste

 

[Eric Penfold]

This is a lot better but how can i scale it to bigger without losing any clarity?

 

[NdNoviceHlp]

If your range was an actual table, then you could refer to it as..

Set Tbl = ws.ListObjects("TableName")
'or 
Set Tbl = ws.ListObjects(1)

Copy and pasting an actual table may improve the clarity? The previous code copies and pastes a picture of the range. You can trial adjusting the range size in XL before the copy or adjust the picture size after the copy to fit the doc size. Alternatively, you can trial pasting the range as a table to the Word doc and then adjusting the table size to fit. See the code here...

[SOLVED] Fit large XL range to Word doc

Can't seem to Google up a working solution to paste and fit a large copied range from XL to a Word document. Here's my unsuccessful attempts. The WordApp is the active Word process. Any help welcomed. Dave 'WordApp.ActiveDocument.content.PasteSpecial Placement:=0 'wdInLine...

www.vbaexpress.com

Good luck. Dave

 

[Eric Penfold]

Tried the code but can`t get the Active x component to work. Any ideas.

 

[NdNoviceHlp]

Not sure that I understand. Tried what code? There is no Active x component in any code. An "Active x" is a control of some sort. Does the "code" error or just doesn't do anything? Maybe a bit more info. Dave

 

[Eric Penfold]

The link you sent had a code in it which I tried but when the code got to.

Set PFWdApp = GetObject(, "word.application")

it says

"ActiveX component can't create object"​

 

[NdNoviceHlp]

Well that is strange. It's the usual code for creating a Word process except I sort of messed it up. It should be...

'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' ***this should be here

'turn on pagination
If PFWdApp.Options.Pagination = False Then
PFWdApp.Options.Pagination = True
PagFlag = True
End If
'End if *** not right
PFWdApp.Visible = True

I don't think this will change your error though. The PFWdApp is defined as an object and the code simply looks for an active Word application and uses it, OR if there is no Word application, it creates one. The "On Error Resume Next" code is especially puzzling as it meant to address the GetObject error when the object doesn't exist. You could just remove that all together and simply go with...

Set PFWdApp = CreateObject("Word.Application")

HTH. Dave