Eric Penfold
Active Member
- Joined
- Nov 19, 2021
- Messages
- 428
- Office Version
- 365
- Platform
- Windows
- Mobile
I copy an image onto a Email but it`s to many MBs (20MBs) can i reduce the MBs in VBA.
Without damaging the quality or size of image.
Without damaging the quality or size of image.
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:=2
Set pic = ws.Pictures.Paste
pic.Select
With Selection
.ShapeRange.LockAspectRatio = msoTrue
.ShapeRange.Height = 8000
End With
pic.Cut
strBody = "<BODY style = font-size:9pt,font- family:arial><Center>" & _
"<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
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 & "<br>" & .HTMLBody & strBody
On Error GoTo 0
End With
Set EmailItem = Nothing
Set EmailApp = Nothing
On Error Resume Next
Workbooks("DailyMail.xlsx").Close
End Sub
