VBA conditional range selection for jpeg

ABourdages

New Member
Joined
Feb 9, 2021
Messages
5
Office Version
  1. 2016
Platform
  1. 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
 

Excel Facts

How can you automate Excel?
Press Alt+F11 from Windows Excel to open the Visual Basic for Applications (VBA) editor.

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
846
Office Version
  1. 365
Platform
  1. Windows
In your worksheet, click anywhere in your pivot table. Click on the Ribbon tab "PivotTable Analyze". In the upper left of the ribbon, right under "File", you will Pivot Table Name, such as PivotTable1.

Change the function call to this (change the pivot table name to match yours):

Rich (BB code):
MakeJPG = CopyRangeToJPG("APPS", Worksheets("APPS").PivotTables("PivotTable1").TableRange2.Address)

P.S. It is very helpful to use code tags when including code, to preserve the formatting and make it more readable
 
Solution

ABourdages

New Member
Joined
Feb 9, 2021
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
In your worksheet, click anywhere in your pivot table. Click on the Ribbon tab "PivotTable Analyze". In the upper left of the ribbon, right under "File", you will Pivot Table Name, such as PivotTable1.

Change the function call to this (change the pivot table name to match yours):

Rich (BB code):
MakeJPG = CopyRangeToJPG("APPS", Worksheets("APPS").PivotTables("PivotTable1").TableRange2.Address)

P.S. It is very helpful to use code tags when including code, to preserve the formatting and make it more readable
This worked perfectly, thank you.

Would there be a way to make a jpeg of 2 or more tables from the same page by modifying this code?

THanks.
 

6StringJazzer

Well-known Member
Joined
Jan 27, 2010
Messages
846
Office Version
  1. 365
Platform
  1. Windows
I am not sure whether CopyPicture will work with a discontinuous range. You could try this but I don't know if it will work:

Rich (BB code):
MakeJPG = CopyRangeToJPG("APPS", Union(Worksheets("APPS").PivotTables("PivotTable1").TableRange2, Worksheets("APPS").PivotTables("PivotTable2").TableRange2).Address)

If it does work I would expect it to give the region of your sheet that includes both tables. If you have other content in between those tables, it would get picked up as well. That may not be what you want.

It might make more sense to do two separate images.

To wring this out I would have to have your file or one similar. I don't have time at the moment to create one from scratch.
 

ABourdages

New Member
Joined
Feb 9, 2021
Messages
5
Office Version
  1. 2016
Platform
  1. Windows
I am not sure whether CopyPicture will work with a discontinuous range. You could try this but I don't know if it will work:

Rich (BB code):
MakeJPG = CopyRangeToJPG("APPS", Union(Worksheets("APPS").PivotTables("PivotTable1").TableRange2, Worksheets("APPS").PivotTables("PivotTable2").TableRange2).Address)

If it does work I would expect it to give the region of your sheet that includes both tables. If you have other content in between those tables, it would get picked up as well. That may not be what you want.

It might make more sense to do two separate images.

To wring this out I would have to have your file or one similar. I don't have time at the moment to create one from scratch.
Thanks, I appreciate it. This works.
 

Watch MrExcel Video

Forum statistics

Threads
1,130,211
Messages
5,640,887
Members
417,177
Latest member
njosh

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top