VBA Save Range as a JPG File ?

[Ken1000]

Hi. I am using Excel 2000.

I have made a macro which will save a range on a Sheet
to a seperate Sheet as a Bitmap file on that Sheet (see code below).

The BMP file format saves images larger than the JPG
(or JPEG) format. Do you know of any VBA code which
could save save a specified range as a seperate, external
JPG file ? By "seperate, external" I mean independent of
Excel and in the same directory as the Excel workbook from
which it derived the picture. (Or, if not a JPG, perhaps as a
GIF file ?)

Or, if a seperate, external JPG file could not be generated
from Excel, could a JPG copy of the range be placed onto a
different Sheet (such as the code I have below).

Also, could such a macro get the name for the intended
JPG file from a cell on the Sheet. For example, from cell A5.
If cell A5 read as "Budget2005", then the JPG would be
saved as Budget2005.jpg.

Thank for your help.

Ken

'-------------------------------------------------

Sub CopyRangeAsBMP()

'choose the Sheet from which you need your picture
Worksheets("SourceSheet").Activate

'specify your range
Range("M11:R73").Select

Selection.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
Range("A1").Select

'Goto the proper Target Sheet and Paste This
Sheets("DestinationSheet").Select

'select cell where Picture will be placed
Range("A1").Select

'Paste the Picture to cell
ActiveSheet.Pictures.Paste.Select

'Position Cursor
Range("M5").Select

End Sub

 

[jolivanes]

Hi Ken.
I forgot to mention to change the sheet names, ranges etc but I am sure you will. It will be interesting to hear how it works and if you make any changes for us to adapt.
Good Luck.
John

 

[Ken1000]

Jolivanes, thanks for your help. Your code also is great,
except the resultign JPG file appears "squished" for the range
I use.

In trying to make somthing similar, I used the Macro Recorder,
and found if I manually resized the Chart it sort of fit better
perspective wise. In other words, I needed to increase the
Chart Width by 1.3 and the Height by 3.61. The Macro Recorder
produced some lines which used words "Scale.Width by"
"Scale.Height by" -- How can you code be amended so that
I (and other users) and resize the chart via code before
the Picture is generated ? In other words, can some kind of
Scale.Width and Scale.height variables be added ?

Thanks very, very much.

Ken

 

[jolivanes]

Hi Ken.
Unfortunately I can't help you with that except suggest to play around with the width and height numbers.

With ChTemp.Parent 
.Width = PicTemp.Width + 8 
.Height = PicTemp.Height + 8 
End With

The other option I think would be to start another thread with the full macro in it and ask for help as this thread is way down the list in the meantime,
Sorry about that Ken but as I mentioned originally, someone else on a forum did this for me. If you do find the solution, would you mind showing it?
Good luck.
John

 

[HarryS]

'
' if you want to do without the chart and pasting it a more direct and maybe faster code like may do the job
'

'Use like
Private Sub CommandButton1_Click()
'RangeToJPG "k3:r23", "D:\labbmp\trya.jpg"  ' a range
RangeToJPG "SelAdd", "D:\labbmp\tryb.jpg"     ' a selection
End Sub

Option Explicit: Option Compare Text
Private Declare Function CreateCompatibleDC& Lib "gdi32" (ByVal Hdc&)
Private Declare Function CreateCompatibleBitmap& Lib "gdi32" (ByVal Hdc&, ByVal nWidth&, ByVal nHeight&)
Private Declare Function DeleteDC& Lib "gdi32" (ByVal Hdc&)
Private Declare Function SelectObject& Lib "gdi32" (ByVal Hdc&, ByVal hObject&)
Private Declare Function DeleteObject& Lib "gdi32" (ByVal hObject&)
Private Declare Sub CLSIDFromString Lib "ole32" (ByVal lpsz As Any, pclsid As Any)
Private Declare Function GetDC& Lib "user32" (ByVal hwnd&)
Private Declare Function OleCreatePictureIndirect& Lib "olepro32.dll" (PicArray As Any, RefIID As Any, ByVal OwnsHandle&, IPic As Any)
Private Declare Function StretchBlt& Lib "gdi32" _
                                     (ByVal Hdc&, ByVal x&, ByVal y&, _
                                      ByVal nWidth&, ByVal nHeight&, _
                                      ByVal hSrcDC&, ByVal xSrc&, ByVal ySrc&, _
                                      ByVal nSrcWidth&, ByVal nSrcHeight&, ByVal dwRop&)  'xxl
'
Public Const nCOPY& = &HCC0020
Private Type PictDesc
    cbSizeofStruct As Long
    picType As Long
    hImage As Long
    xExt As Long
    yExt As Long
End Type
'
' there is some difference but both work OK here
'Private Const StdPicGUID$ = "{7BF80980-BF32-101A-8BBB-00AA00300CAB}"
Private Const StdPicGUID$ = "{00020400-0000-0000-C000-000000000046}"
'
'get the  range ....   left top width height in pixels
'
Sub RangeToPix(L&, T&, W&, H&, Optional RaAd$ = "SelAdd")
'assuming screen as normal pts to pix of 3:4... zoom is a percent
'
    Dim Zoomp!: Zoomp = ActiveWindow.Zoom / 75
    If RaAd = "SelAdd" Then RaAd = Selection.Address
    '
    With Range(RaAd)
        L = .Left * Zoomp
        T = .Top * Zoomp
        W = .Width * Zoomp
        H = .Height * Zoomp
    End With
    L = L + ActiveWindow.PointsToScreenPixelsX(0)
    T = T + ActiveWindow.PointsToScreenPixelsY(0)
End Sub
'
' a selection or a range from a worksheet  >>> JPG file
'
Sub RangeToJPG(RaAd$, ToFileBmp$, Optional WidthFac! = 1!, Optional HeightFac! = 1!)
    Dim MBMPhdc&, hMbmp&, Hwnd0&
    Dim wPic As stdole.IPicture, PicDes As PictDesc, IPic(15) As Byte
    Dim L&, T&, W&, H&, Wt&, Ht&
    '
    RangeToPix L, T, W, H, RaAd  ' to pixels'
    Wt = W * WidthFac
    Ht = H * HeightFac
    Hwnd0 = GetDC(0)    ' screen
    '
    ' range needs to be visible on the worksheet  .. zoom it to show all
    '
    'Make the Memory bit map
    '
    MBMPhdc = CreateCompatibleDC(Hwnd0)  ' get an application DC
    hMbmp = CreateCompatibleBitmap(Hwnd0, Wt, Ht)    ' make map to size
    DeleteObject SelectObject(MBMPhdc, hMbmp)   ' set the Memory HDC
    ' using StretchBlt to scale  size
    StretchBlt MBMPhdc, 0, 0, Wt, Ht, Hwnd0, L, T, W, H, nCOPY    ' copy to memory Bit Map
    ' as Pic
    '
    PicDes.picType = 1
    PicDes.hImage = hMbmp
    PicDes.cbSizeofStruct = Len(PicDes)
    CLSIDFromString StrPtr(StdPicGUID), IPic(0)
    OleCreatePictureIndirect PicDes, IPic(0), True, wPic
    SavePicture wPic, ToFileBmp
    'tidy memory
    DeleteObject hMbmp
    DeleteObject MBMPhdc
    DeleteDC MBMPhdc    'should there be a DeleteDC also ????
End Sub

 

[EitanOrgil]

Hi Ken
Following were supplied to me by people a lot more knowledgeable than I am. I don't think there is any problems with supplying it to people wanting the code. If so, my apologies.

This macro exports a chart as a picture

Sub ExportChartsJPG()
Application.ScreenUpdating = False
Sheets("MondayChart").Select
  ActiveChart.Export Filename:="D:\My Documents\My Pics\MondayChart.jpg", _
  FilterName:="jpg"
Sheets("MondayYearly").Select
  Application.ScreenUpdating = False
End Sub

Following macro exports a range as a picture

Sub ExportNumChart()
Const FName As String = "D:\My Documents\My Pics\Numbers.jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Numbers").Range("B1:F25")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 8
.Height = PicTemp.Height + 8
End With
ChTemp.Export Filename:="D:\My Documents\My Pics\Numbers.jpg", FilterName:="jpg"
'UserForm1.Image1.Picture = LoadPicture(FName)
'Kill FName
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Good Luck
John

Hi John,

I used your solution for range as a picture, but with a twist, I run the code on Outlook, identifying a mail "from Somone" with Rules And Alerts and then from Rules And Alerts running the script.
So far my code is running but I hit a bump with the line: Set PicTemp = selection
I can run the code without it, but then I miss the "with" part where you set the pic size to be: PicTemp.Width + 8 and PicTemp.Height + 8.

Here is the piece of Code I have (with the updates to use excel from outlook):
(Cradit to the Original Code, from Excel Automation - Ron de Bruin)

Sub SaveSend_Embedded_Chart()
'Working in 2000-2016
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
 Dim xlApp As Object
 Dim xlWkb As Object
 Dim xlSheet As Object
 Dim OutApp As Object
 Dim OutMail As Object
 Dim FName As String
 Dim FName1 As String
 Dim StrBody As String
 Dim pic_rng As Range
 Dim ShTemp As Worksheet
 Dim ChTemp As Chart
 Dim PicTemp As Picture 
 StrBody = "Attached are graph and Sum table"
 Set OutApp = CreateObject("Outlook.Application")
 Set OutMail = OutApp.CreateItem(0)
 'File path/name of the gif files
 FName = Environ$("temp") & "\RQ_Graph.gif"
 FName1 = Environ$("temp") & "\RQ_Range.gif"
 'Open existing excel file
 Set xlApp = CreateObject("Excel.Application")
 xlApp.Visible = True
 Set xlWkb = xlApp.Workbooks.Open("C:\Users\Eitan\Documents\Report.xlsm")
 Set xlSheet = xlWkb.Sheets("Sheet2")
 xlApp.Worksheets("Sheet2").Activate
 '***************************************************************
 ' Save Chart named "Chart 3" as gif Using Fname                *
 '***************************************************************
 xlSheet.ChartObjects("Chart 3").Chart.Export _
     FileName:=FName, FilterName:="GIF"
 '******************************************
 ' Save range K22:P32 as gif  using FName1 *
 '******************************************
 Set pic_rng = xlSheet.Range("K22:P32")
 Set ShTemp = xlApp.Worksheets.Add
 xlApp.Charts.Add
 xlApp.ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
 Set ChTemp = xlApp.ActiveChart
 pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
 ChTemp.Paste
 Set PicTemp = Selection
 With ChTemp.Parent
    .Width = xlApp.PicTemp.Width + 8
    .Height = xlApp.PicTemp.Height + 8
 End With
 ChTemp.Export FileName:=FName1
 xlApp.Application.DisplayAlerts = False
 ShTemp.Delete
 xlApp.Application.DisplayAlerts = True
 OutMail.Display
 With OutMail
     .To = "me@mydomain.com"
     .Subject = "Daily Report"
     .HTMLBody = StrBody
     .Attachments.Add FName
     .Attachments.Add FName1
     .Send   'or use .Display '
 End With
 On Error GoTo 0
 'Delete the gif file
 Kill FName
 Kill FName1
 Set OutMail = Nothing
 Set OutApp = Nothing
 xlWkb.Save
 xlWkb.Close
 xlApp.Quit
End Sub

Hope I made myself clear
Eitan

 

[Smiliej]

Hi,

Is it also possible to do such action with a shared workbook. The code I'm using only works when it's not shared.

Kind regards

Sub JPEG_Export()


'Exporteren voor het beeldscherm in de kantine
Const FName As String = "\\intr00\infoschermen\Dagplanning.jpg"
Dim pic_rng As Range
Dim ShTemp As Worksheet
Dim ChTemp As Chart
Dim PicTemp As Picture
Application.ScreenUpdating = False
Set pic_rng = Worksheets("Kantinepresentatie").Range("A1:L14")
Set ShTemp = Worksheets.Add
Charts.Add
ActiveChart.Location Where:=xlLocationAsObject, Name:=ShTemp.Name
Set ChTemp = ActiveChart
pic_rng.CopyPicture Appearance:=xlScreen, Format:=xlPicture
ChTemp.Paste
Set PicTemp = Selection
With ChTemp.Parent
.Width = PicTemp.Width + 500
.Height = PicTemp.Height + 250
End With
ChTemp.Export Filename:="\\intr00\infoschermen\Dagplanning.jpg", FilterName:="jpg"
'UserForm1.Image1.Picture = LoadPicture(FName)
'Kill FName
Application.DisplayAlerts = False
ShTemp.Delete
Application.DisplayAlerts = True
Application.ScreenUpdating = True




End Sub