ABourdages
New Member
- Joined
- Feb 9, 2021
- Messages
- 5
- Office Version
- 2016
- Platform
- Windows
Hello,
I made an active X button that takes a range and turns it into a jpeg and then sends it by e-mail.
I need this selection to be conditional as the range will vary since it is based on a pivot table.
Here is the code:
Private Sub CommandButton1_Click()
Dim xOutApp As Object
Dim xOutMail As Object
Dim MakeJPG As String
Dim strbody As String
strbody = Worksheets("TXT Email").Range("A3").Value
EndText = Replace(strbody, " ", "<br><br>")
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
MakeJPG = CopyRangeToJPG("APPS", "A8:I27")
If MakeJPG = "" Then
MsgBox "Something went wrong, could not complete operation."
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
With xOutMail
.To = Join(Application.Transpose(Worksheets("APPS").Range("AA7:AA10").Value), ";")
.CC = Join(Application.Transpose(Worksheets("APPS").Range("AA11:AA14").Value), ";")
.BCC = ""
.Subject = Worksheets("TXT Email").Range("A2").Value
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = EndText & "<html><p>" & "</p><img src=""cid:NamePicture.jpg"" width=600 height=300></html>" & vbNewLine
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
I made an active X button that takes a range and turns it into a jpeg and then sends it by e-mail.
I need this selection to be conditional as the range will vary since it is based on a pivot table.
Here is the code:
Private Sub CommandButton1_Click()
Dim xOutApp As Object
Dim xOutMail As Object
Dim MakeJPG As String
Dim strbody As String
strbody = Worksheets("TXT Email").Range("A3").Value
EndText = Replace(strbody, " ", "<br><br>")
On Error Resume Next
Set xOutApp = CreateObject("Outlook.Application")
Set xOutMail = xOutApp.CreateItem(0)
MakeJPG = CopyRangeToJPG("APPS", "A8:I27")
If MakeJPG = "" Then
MsgBox "Something went wrong, could not complete operation."
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Exit Sub
End If
On Error Resume Next
With xOutMail
.To = Join(Application.Transpose(Worksheets("APPS").Range("AA7:AA10").Value), ";")
.CC = Join(Application.Transpose(Worksheets("APPS").Range("AA11:AA14").Value), ";")
.BCC = ""
.Subject = Worksheets("TXT Email").Range("A2").Value
.Attachments.Add MakeJPG, 1, 0
.HTMLBody = EndText & "<html><p>" & "</p><img src=""cid:NamePicture.jpg"" width=600 height=300></html>" & vbNewLine
.Display
End With
On Error GoTo 0
Set xOutMail = Nothing
Set xOutApp = Nothing
End Sub
Function CopyRangeToJPG(NameWorksheet As String, RangeAddress As String) As String
Dim PictureRange As Range
With ActiveWorkbook
On Error Resume Next
.Worksheets(NameWorksheet).Activate
Set PictureRange = .Worksheets(NameWorksheet).Range(RangeAddress)
If PictureRange Is Nothing Then
MsgBox "Sorry this is not a correct range"
On Error GoTo 0
Exit Function
End If
PictureRange.CopyPicture
With .Worksheets(NameWorksheet).ChartObjects.Add(PictureRange.Left, PictureRange.Top, PictureRange.Width, PictureRange.Height)
.Activate
.Chart.Paste
.Chart.Export Environ$("temp") & Application.PathSeparator & "NamePicture.jpg", "JPG"
End With
.Worksheets(NameWorksheet).ChartObjects(.Worksheets(NameWorksheet).ChartObjects.Count).Delete
End With
CopyRangeToJPG = Environ$("temp") & Application.PathSeparator & "NamePicture.jpg"
Set PictureRange = Nothing
End Function
