route217
asked on
Jpg image not visible - once macro has run
Hi Experts
The following macro was excellently provided to me by one of the experts on this site.
However, once the macro has run the attachment file .jpg is blank and also I wish to edit the macro so the data is in the body of the email as opposed to an attachment.
Option explicit
Dim container As Chart
Dim containerbook As Workbook
Dim Sourcebook As Workbook
Sub Mail_Daily()
Dim rng As Range
Dim Outapp As Object
Dim OutMail As Object
Dim StrBody As String
Dim StrBodySig As String
Dim strpath As String
Dim Test As String
Dim sPath As String
Dim Folder As Object
Dim oFSO As Object
Dim strExtension As String
Dim SignaturePath As String
Dim SignaturePathFound As String
Application.DisplayAlerts = False
Application.ScreenUpdating = False
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlC ellTypeVis ible)
Set rng = Sheets("Blackberry").Range ("B4:H30") .SpecialCe lls(xlCell TypeVisibl e)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Outapp = CreateObject("Outlook.Appl ication")
Set OutMail = Outapp.CreateItem(0)
StrBody = "<p style='font-family:calibri ;font-size :12'>" & "Dear All" & "<br><br>" & _
"Please find attached the Daily R&WO Performance Dashboard for - " & Format(Now, "dd mmmm yyyy") & "." & "<br>" & _
"Please find below an image developed for users viewing this email on a Blackberry device who are unable to open pdf attachments this image" & "<br>" & _
"shows the key metrics for each of the functional teams, highlighting Current Rolling Week and MTD figures and associated RAG statuses." & "<br>" & _
"<br>If you have any difficulties viewing the table above via a Blackberry device, please contact sender:- Details Below." & "<p style>"
strpath = CreateObject("WScript.Shel l").specia lfolders(" AppData") & "\Microsoft\Signatures\"
' these go on every line and give the main information about the file
strExtension = Dir(strpath & "\*.htm")
SignaturePathFound = "No"
If strExtension = "" Then
MsgBox ("You dont have an outlook signature set up - please update")
Exit Sub
Else
SignaturePath = strpath & strExtension
SignaturePathFound = "Yes"
End If
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.Subject = "Executive Summary Report - " & Format(Now, "dd mmmm yyyy") & ""
If SignaturePathFound = "Yes" Then
.HTMLBody = StrBody & GetBoiler(SignaturePath)
Else
.HTMLBody = StrBody
End If
.Attachments.Add RangeToJPEG(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set Outapp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.Fi leSystemOb ject")
Set ts = fso.GetFile(sFile).OpenAsT extStream( 1, -2)
GetBoiler = ts.ReadAll
ts.Close
End Function
Function RangeToJPEG(rng As Range) As String
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim Hi As Integer
Dim Wi As Integer
Set Sourcebook = rng.Parent.Parent
Set containerbook = Workbooks.Add(1)
containerbook.Sheets(1).Na me = "JPGcontainer"
MySuggest = sShortname(rng.Worksheet.N ame)
Set container = CreateContainer(containerb ook)
MyAddress = rng.Address
If MyAddress <> "A1" Then
SaveName = CreateObject("WScript.Shel l").specia lfolders(" MyDocument s") & "\temp.jpg"
If Dir(SaveName) <> "" Then Kill SaveName
With rng
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Hi = .Height + 4 'adjustment for gridlines
Wi = .Width + 6 'adjustment for gridlines
End With
MakeAndSizeChart container, ih:=Hi, iv:=Wi
With container
.Paste
.Export Filename:=SaveName, FilterName:="jpg"
.Pictures(1).Delete
End With
Sourcebook.Activate
End If
RangeToJPEG = SaveName
On Error Resume Next
Application.StatusBar = False
containerbook.Close False
End Function
Function sShortname(ByVal Original As String) As String
Dim i As Integer
sShortname = ""
i = InStr(Trim$(Original), " ")
If i = 0 Then
sShortname = Original
Else
sShortname = Left$(Original, i - 1)
End If
End Function
Private Function CreateContainer(ByRef wbk As Workbook) As Chart
Set container = wbk.Charts.Add
With container
.ChartType = xlColumnClustered
.SetSourceData Source:=wbk.Worksheets(1). Range("A1" )
.Location Where:=xlLocationAsObject, Name:=wbk.Sheets(2).Name
End With
Set CreateContainer = ActiveChart
CreateContainer.ChartArea. ClearConte nts
End Function
Sub MakeAndSizeChart(ByRef cht As Chart, ih As Integer, iv As Integer)
Dim Hincrease As Single
Dim Vincrease As Single
Hincrease = ih / cht.ChartArea.Height
cht.Parent.ShapeRange.Scal eHeight Hincrease, _
msoFalse, msoScaleFromTopLeft
Vincrease = iv / cht.ChartArea.Width
cht.Parent.ShapeRange.Scal eWidth Vincrease, _
msoFalse, msoScaleFromTopLeft
End Sub
:
The following macro was excellently provided to me by one of the experts on this site.
However, once the macro has run the attachment file .jpg is blank and also I wish to edit the macro so the data is in the body of the email as opposed to an attachment.
Option explicit
Dim container As Chart
Dim containerbook As Workbook
Dim Sourcebook As Workbook
Sub Mail_Daily()
Dim rng As Range
Dim Outapp As Object
Dim OutMail As Object
Dim StrBody As String
Dim StrBodySig As String
Dim strpath As String
Dim Test As String
Dim sPath As String
Dim Folder As Object
Dim oFSO As Object
Dim strExtension As String
Dim SignaturePath As String
Dim SignaturePathFound As String
Application.DisplayAlerts = False
Application.ScreenUpdating
Set rng = Nothing
On Error Resume Next
Set rng = Selection.SpecialCells(xlC
Set rng = Sheets("Blackberry").Range
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set Outapp = CreateObject("Outlook.Appl
Set OutMail = Outapp.CreateItem(0)
StrBody = "<p style='font-family:calibri
"Please find attached the Daily R&WO Performance Dashboard for - " & Format(Now, "dd mmmm yyyy") & "." & "<br>" & _
"Please find below an image developed for users viewing this email on a Blackberry device who are unable to open pdf attachments this image" & "<br>" & _
"shows the key metrics for each of the functional teams, highlighting Current Rolling Week and MTD figures and associated RAG statuses." & "<br>" & _
"<br>If you have any difficulties viewing the table above via a Blackberry device, please contact sender:- Details Below." & "<p style>"
strpath = CreateObject("WScript.Shel
' these go on every line and give the main information about the file
strExtension = Dir(strpath & "\*.htm")
SignaturePathFound = "No"
If strExtension = "" Then
MsgBox ("You dont have an outlook signature set up - please update")
Exit Sub
Else
SignaturePath = strpath & strExtension
SignaturePathFound = "Yes"
End If
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.Subject = "Executive Summary Report - " & Format(Now, "dd mmmm yyyy") & ""
If SignaturePathFound = "Yes" Then
.HTMLBody = StrBody & GetBoiler(SignaturePath)
Else
.HTMLBody = StrBody
End If
.Attachments.Add RangeToJPEG(rng)
.Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set Outapp = Nothing
End Sub
Function GetBoiler(ByVal sFile As String) As String
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.Fi
Set ts = fso.GetFile(sFile).OpenAsT
GetBoiler = ts.ReadAll
ts.Close
End Function
Function RangeToJPEG(rng As Range) As String
Dim varReturn As Variant
Dim MyAddress As String
Dim SaveName As Variant
Dim MySuggest As String
Dim Hi As Integer
Dim Wi As Integer
Set Sourcebook = rng.Parent.Parent
Set containerbook = Workbooks.Add(1)
containerbook.Sheets(1).Na
MySuggest = sShortname(rng.Worksheet.N
Set container = CreateContainer(containerb
MyAddress = rng.Address
If MyAddress <> "A1" Then
SaveName = CreateObject("WScript.Shel
If Dir(SaveName) <> "" Then Kill SaveName
With rng
.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Hi = .Height + 4 'adjustment for gridlines
Wi = .Width + 6 'adjustment for gridlines
End With
MakeAndSizeChart container, ih:=Hi, iv:=Wi
With container
.Paste
.Export Filename:=SaveName, FilterName:="jpg"
.Pictures(1).Delete
End With
Sourcebook.Activate
End If
RangeToJPEG = SaveName
On Error Resume Next
Application.StatusBar = False
containerbook.Close False
End Function
Function sShortname(ByVal Original As String) As String
Dim i As Integer
sShortname = ""
i = InStr(Trim$(Original), " ")
If i = 0 Then
sShortname = Original
Else
sShortname = Left$(Original, i - 1)
End If
End Function
Private Function CreateContainer(ByRef wbk As Workbook) As Chart
Set container = wbk.Charts.Add
With container
.ChartType = xlColumnClustered
.SetSourceData Source:=wbk.Worksheets(1).
.Location Where:=xlLocationAsObject,
End With
Set CreateContainer = ActiveChart
CreateContainer.ChartArea.
End Function
Sub MakeAndSizeChart(ByRef cht As Chart, ih As Integer, iv As Integer)
Dim Hincrease As Single
Dim Vincrease As Single
Hincrease = ih / cht.ChartArea.Height
cht.Parent.ShapeRange.Scal
msoFalse, msoScaleFromTopLeft
Vincrease = iv / cht.ChartArea.Width
cht.Parent.ShapeRange.Scal
msoFalse, msoScaleFromTopLeft
End Sub
:
Why not just take a screen shot and paste it into the email?
ASKER CERTIFIED SOLUTION
membership
This solution is only available to members.
To access this solution, you must be a member of Experts Exchange.
ASKER
Also this macro is trying to add a chart on the specified range - where as I have a data on the range in the form of a table...
The data range is in the first sub procedure...