Eric Penfold
Active Member
- Joined
- Nov 19, 2021
- Messages
- 431
- Office Version
- 365
- Platform
- Windows
- Mobile
This code below is set to
but it`s blurry so what Format should I use instead?
I`ve tried various different Formats but it just makes the image small & I can`t seem to change the size with VBA??
VBA Code:
PasteAndFormat 13I`ve tried various different Formats but it just makes the image small & I can`t seem to change the size with VBA??
VBA Code:
Sub SendDailyMailEmail()
Dim wb As Workbook
Dim ws As Worksheet, ews As Worksheet
Dim Tbl As Range, rng As Range
Dim LRow As Long
Dim EmailApp As Object, EmailItem As Object
Dim pic As Picture
Dim WordDoc
Dim strBody As String, Text As String
Set EmailApp = CreateObject("Outlook.Application")
Set EmailItem = EmailApp.CreateItem(0)
Set wb = Workbooks("Personal.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.CopyPicture Appearance:=xlScreen, Format:=xlPicture
Set pic = ws.Pictures.Paste
pic.Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 2000
End With
pic.Cut
strBody = "<BODY style = font-size:9pt,font- family:arial>" & _
"<br><br><a href=""https://app.smartsheet.com/b/form/05bee75bfa6a47b7b5c5cff74e64dc3d"">Brainstorm Suggestions</a><br><br>" & _
"<a href=""\\DF-AZ-FILE01\Company\R&D\Product Development\Product Ideas.xlsx"">Product Ideas</a>"
On Error Resume Next
With EmailItem
.To = "Drainfast Daily Mail"
.CC = ""
.Subject = "Drainfast Daily Mail" & " " & Format(Date, "dd-mm-yyyy")
.Display
.HTMLBody = strBody & .HTMLBody
On Error GoTo 0
Set WordDoc = EmailItem.GetInspector.WordEditor
On Error Resume Next
With WordDoc.Range
.PasteAndFormat 13
.Application.Selection.Paragraphs.Alignment = wdAlignParagraphCenter
End With
Text = "<BODY style = font-size:9pt,font- family:arial>" & _
"Morning Staff,<br><br>Daily Mail Below<br><br><br>"
.HTMLBody = Text & .HTMLBody
On Error GoTo 0
End With
Set EmailItem = Nothing
Set EmailApp = Nothing
On Error Resume Next
Workbooks("DailyMail.xlsx").Close
End Sub
