Range to Image

L

lawvictor

New Member
Joined
Jul 29, 2017
Messages
27
Hi All,
I ma writing a script to covert a given range into image, i found a code from which was working fine as long as the range was smaller width but the moment i increased the width of the column it is not working, the whole image is not creating. the below is the steps how the code works,
1) selects the range, find it height and width,
2) inserts a chart and changes the height and width to the range height and width,
3) paste the copied range into the chart
4) export the chart as image.

i find that the chart gets modified to the size of the range however the image pasted in it is no the full image,

any help would be useful.
 
Sort by date Sort by votes
Try this
- amend the filepath & name
- run the macro

Input box asks user for range (otherwise defaults to current selected range)
- select with mouse or type it in

Code: 
Sub RangeToJpg()
    Dim oChart As Chart, Ws As Worksheet, Shp As Shape, Rng As Range
    Set Rng = Application.InputBox("Select a range to copy", "Range to jpg", Selection.Address, , , , , 8)
    If Rng Is Nothing Then Exit Sub

    Set Ws = Rng.Worksheet
    Rng.Copy:   Ws.Pictures.Paste.Select
    Set Shp = Ws.Shapes(Ws.Shapes.Count)

    Set oChart = Charts.Add
    oChart.ChartArea.Clear
    
    Set oChart = oChart.Location(Where:=xlLocationAsObject, Name:=Ws.Name)
    With oChart.ChartArea
        .Width = Shp.Width
        .Height = Shp.Height
        Shp.Copy
        oChart.ChartArea.Select
    End With
    With oChart
        .Paste
        .Export Filename:="[COLOR=#ff0000]C:\test\SavedRange.jpg[/COLOR]", FilterName:="jpg"
    End With
    Ws.ChartObjects(Ws.ChartObjects.Count).Delete
    Shp.Delete
End Sub
 
Last edited:
Upvote 0

Excel Facts

Copy a format multiple times
Select a formatted range. Double-click the Format Painter (left side of Home tab). You can paste formatting multiple times. Esc to stop
Like the other thread, I can not duplicate the problem. Does it get the right range pic when the range is blank?

Maybe post a link to an example file that has the problem?
 
Upvote 0
Yes, i gave it a try, it works fine when the range is small, but fails when the range is big. Like order of CD11
 
Upvote 0
Ken i tried exact code what Jaffar had in the other link, it worked really good, however when the range was increased to A1:CD11 it gives image of only that portion of the range which is visible on the screen. That is when the the excel sheet is zoomed out to the lowest value. Am working with excel 2013, is it something to do with that version of excel.
 
Upvote 0
Did you try post#11 code?
 
Last edited:
Upvote 0
Can you try setting the Visible Range to A1:CD11 right before running the code and then set it back to its original ?
 
Upvote 0
It must be an Excel version issue.

Zoom does not matter for me in 365 using the API and Chart methods.

I guess you tried different Applications to view your created JPG file? Paint is a common one to easily see the image.
 
Last edited:
Upvote 0
See if this works for you -- Run the Test Macro : (Change the Sheet, Range and file path to suit)
Code: 
Option Explicit

Private Type uPicDesc
    Size As Long
    Type As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        hPic As LongPtr
        hPal As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
       hPic As Long
       hPal As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type GUID
   Data1 As Long
   Data2 As Integer
   Data3 As Integer
   Data4(0 To 7) As Byte
End Type

Private Type GdiplusStartupInput
   GdiplusVersion As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        DebugEventCallback As LongPtr
        SuppressBackgroundThread As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        DebugEventCallback As Long
        SuppressBackgroundThread As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
   SuppressExternalCodecs As Long
End Type

Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   Type As Long
   [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Value As LongPtr
   [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Value As Long
   [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If
End Type

Private Type EncoderParameters
   Count As Long
   Parameter As EncoderParameter
End Type


[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
    
    Private Declare PtrSafe Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare PtrSafe Function CopyImage Lib "user32" (ByVal handle As LongPtr, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As LongPtr
    Private Declare PtrSafe Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As LongPtr
    Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As LongPtr, ByVal wMsg As Long, ByVal wParam As LongPtr, lParam As Any) As LongPtr
    
    'GDI+ APIS.
    Private Declare PtrSafe Function GdiplusStartup Lib "GDIPlus" (token As LongPtr, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare PtrSafe Function GdiplusShutdown Lib "GDIPlus" (ByVal token As LongPtr) As Long
    Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, Bitmap As LongPtr) As Long
    Private Declare PtrSafe Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As LongPtr) As LongPtr
    Private Declare PtrSafe Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As LongPtr, ByVal Filename As LongPtr, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, id As GUID) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 

    Private Declare Function OleCreatePictureIndirectAut Lib "oleAut32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function OleCreatePictureIndirectPro Lib "olepro32.dll" Alias "OleCreatePictureIndirect" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, iPic As IPicture) As Long
    Private Declare Function CopyImage Lib "user32" (ByVal handle As Long, ByVal un1 As Long, ByVal n1 As Long, ByVal n2 As Long, ByVal un2 As Long) As Long
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Long) As Long
    Private Declare Function LoadLibrary Lib "kernel32" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
    Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
    Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long

    'GDI+ APIS.
    Private Declare Function GdiplusStartup Lib "GDIPlus" (token As Long, inputbuf As GdiplusStartupInput, Optional ByVal outputbuf As Long = 0) As Long
    Private Declare Function GdiplusShutdown Lib "GDIPlus" (ByVal token As Long) As Long
    Private Declare Function GdipCreateBitmapFromHBITMAP Lib "GDIPlus" (ByVal hbm As Long, ByVal hPal As Long, Bitmap As Long) As Long
    Private Declare Function GdipDisposeImage Lib "GDIPlus" (ByVal Image As Long) As Long
    Private Declare Function GdipSaveImageToFile Lib "GDIPlus" (ByVal Image As Long, ByVal Filename As Long, clsidEncoder As GUID, encoderParams As Any) As Long
    Private Declare Function CLSIDFromString Lib "ole32" (ByVal str As Long, id As GUID) As Long

[URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

Private Const IMAGE_BITMAP = 0
Private Const PICTYPE_BITMAP = 1
Private Const LR_COPYRETURNORG = &H4
Private Const CF_BITMAP = 2
Private Const S_OK = 0
Private Const WM_SETREDRAW = &HB


Sub Test()

    Call PicTureToJPGFile _
    ( _
            Pict:=CreatePicture([COLOR=#ff0000][B]Sheet1.Range("A1:CD11")[/B][/COLOR]), _
            Filename:="[B][COLOR=#ff0000]C:\Test\RangeImage.jpg[/COLOR][/B]" _
    )

End Sub


Public Sub PicTureToJPGFile(ByVal Pict As IPicture, ByVal Filename As String, Optional ByVal Quality As Byte = 100)
   
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim lGDIP As LongPtr, lBitmap As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim lGDIP As Long, lBitmap As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim tSI As GdiplusStartupInput, lRes As Long
    Dim tJpgEncoder As GUID, tParams As EncoderParameters

   tSI.GdiplusVersion = 1
   lRes = GdiplusStartup(lGDIP, tSI)

   If lRes = 0 Then
      lRes = GdipCreateBitmapFromHBITMAP(Pict.handle, 0, lBitmap)
      If lRes = 0 Then
         CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
         tParams.Count = 1
         With tParams.Parameter
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
            .NumberOfValues = 1
            .Type = 4
            .Value = VarPtr(Quality)
         End With
         lRes = GdipSaveImageToFile(lBitmap, StrPtr(Filename), tJpgEncoder, tParams)
         GdipDisposeImage lBitmap
      End If
      GdiplusShutdown lGDIP
   End If
   
   If lRes Then
      Err.Raise 5, , "Cannot save the image. GDI+ Error:" & lRes
   End If
   
End Sub


Public Function CreatePicture(ByVal Obj As Object) As IPicture

    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If"]#If[/URL]  VBA7 Then
        Dim hCopy As LongPtr, hPtr As LongPtr, hLib As LongPtr
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else"]#Else[/URL] 
        Dim hCopy As Long, hPtr As Long, hLib As Long
    [URL="https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End"]#End[/URL]  If

    Dim IID_IDispatch As GUID, uPicinfo As uPicDesc
    Dim iPic As IPicture, lRet As Long
    Dim lPrevZoom As Long
    Dim oPrevSheet As Worksheet, oPrevRange As Range
    
    On Error GoTo errHandler

    Set oPrevSheet = ActiveSheet
    SendMessage Application.hwnd, ByVal WM_SETREDRAW, ByVal 0&, 0&
    Application.EnableEvents = False
    Obj.Parent.Select
    Set oPrevRange = Selection
    Obj.Select
    lPrevZoom = ActiveWindow.Zoom
    ActiveWindow.Zoom = True

    Obj.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    OpenClipboard 0
    hPtr = GetClipboardData(CF_BITMAP)
    hCopy = CopyImage(hPtr, IMAGE_BITMAP, 0, 0, LR_COPYRETURNORG)
    With IID_IDispatch
        .Data1 = &H20400
        .Data4(0) = &HC0
        .Data4(7) = &H46
    End With
    With uPicinfo
        .Size = Len(uPicinfo)
        .Type = PICTYPE_BITMAP
        .hPic = hCopy
        .hPal = 0
    End With
    hLib = LoadLibrary("oleAut32.dll")
    If hLib Then
        lRet = OleCreatePictureIndirectAut(uPicinfo, IID_IDispatch, True, iPic)
    Else
        lRet = OleCreatePictureIndirectPro(uPicinfo, IID_IDispatch, True, iPic)
    End If
    FreeLibrary hLib
    If lRet = S_OK Then
        Set CreatePicture = iPic
    End If
    
errHandler:
    EmptyClipboard
    CloseClipboard
    ActiveWindow.Zoom = lPrevZoom
    oPrevRange.Select
    oPrevSheet.Select
    Application.EnableEvents = True
    SendMessage Application.hwnd, ByVal WM_SETREDRAW, ByVal 1&, 0&
    
    If Err Then
      Err.Raise 5, , "Cannot Create Picture."
     End If
   
End Function
 
Last edited:
Upvote 0
Hi Jaffar, i tried the exact code, it is still a failure, what could be the factor, is it because of Excel 2013, or could be any other issue. Do you think is there any other means of saving this range and viewing it apart from converting to the image, for example like pdf only this sheet and range to be saved in a single page in the pdf. Could someone provide some hint.
 
Upvote 0
You must log in or register to reply here.

Similar threads

O
  • Solved
VBA - floating photo
Replies
3
Views
527
RoryA
RoryA
F
  • Question Question
See the Chart Height/ Width values in cells
Replies
1
Views
291
Frankroger
F
Jeffrey Mahoney
  • Question Question
ActiveX Textbox Height Width Setting Problem
Replies
9
Views
224
Jeffrey Mahoney
Jeffrey Mahoney
Y
  • Solved
Creating a Pie Chart based on a Dynamic Range
Replies
6
Views
281
Yeft
Y
M
  • Question Question
Please help me to correct Excel VBA code!
Replies
1
Views
368
Minh Tuan VN
M

Forum statistics

Threads
1,224,824
Messages
6,181,186
Members
453,020
Latest member
Mohamed Magdi Tawfiq Emam

Share this page

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
Back
Top