vba to screen-shot a given range on every worksheet in file

P

palaeontology

Active Member
Joined
May 12, 2017
Messages
444
Office Version
  1. 2016
Platform
  1. Windows
Is it possible to have code that takes a screen-shot of all sheets named with a 5-digit student ID number (eg: 69213) and save that image as a jpeg (named with the same 5-digit code as the sheet the image came from) in the same folder (called ... 2019) as where the spreadsheet is housed ?

The range (to be screen-shot) on each sheet would be A1:AU36

Each week I'd be running this code again, so is there a way for the code to delete all previously made jpeg image files in that folder and replace them with the new ones, or would I have to have them saved each week as a new sub-file ... perhaps with the word 'images' at the front and the date-stamp after it ... eg: Images 7/02/2019

The address of the folder where the spreadsheet is currently housed is ... D:\A_CHRIS (school)\A_MATHS\HW Data Collection and MailMerge\2019 ... but as this will eventually be used by others in this school on their own laptops, this address will vary considerably for each teacher.

The address of the spreadsheet itself is ... D:\A_CHRIS(school)\A_MATHS\HW Data Collection and MailMerge\2019\[Math Homework Mailmerge Practice.xlsm]

Please let me know if there's anything else I'd need to provide you.

Kind regards,

Chris
 

Excel Facts

Last used cell?
Press Ctrl+End to move to what Excel thinks is the last used cell.
Sort by date Sort by votes
Welcome to the forum!

There are 2 ways to do it.
1. API
2. Scratch Chart

There are several threads around that explain these 2 methods. e.g. https://www.mrexcel.com/forum/excel-questions/142662-vba-save-range-jpg-file.html

API method is faster. It produces a BMP file type. The code may not work for all users. It depends on 32bit vs. 64bit Excel. Most API methods for this use 32bit.

The Chart method does produce a true JPG but is slower. If I used the chart method, I would use a scratch workbook to hold the scratch chart.

Once you choose a method, it is s simple matter to iterate the sheets to get the ones you want.
 
Upvote 0
Ken, as appoint of interest and learning (not a thread hijack) …
"If I used the chart method, I would use a scratch workbook to hold the scratch chart."
Why not just temporarily create a chart object on a sheet of the current wb and then remove it once it's done it's thing? Jaafar has some good code posted for API and it is quick.. not sure if it's coded for 32 and 64 bit. Dave
 
Upvote 0
That is a relevant question. Why would I used a scratch workbook rather than a scratch worksheet or scratch chart in a production workbook? There are 3 reasons: file bloat, file corruption, and chart object retention (ghosts). Maybe deleting the scratch worksheet will suffice but I don't like taking chances. I want none of those problems in my production workbook. Howsoever, many have used temporary worksheets and charts with success. When i help others, sometimes this might involve hundreds of calls to do their tasks. As the frequency increases, so does the risk, IMHO.

IF you see PtrSafe in the API code, it is most usually 64 bit ready. One can code for both in the same workbook, "sometimes". For one of these API routines, I have not had success with the 64 bit version. I haven't asked anyone to test it with their 64 bit Excel. The 32 bit version is my usual preferred method for my 32 bit Excel.

When I get time, I may work up a scratch workbook, chart export routine. The idea would be to have it, after 1st call, to keep the scratch workbook open for multiple calls in one session. That would save a bit of time. I tend to code in a modular reusable way.

As I said, there are many examples around the web and this forum that use both methods.
 
Upvote 0
Thanks Ken for your sage opinions. I have not yet trialled 64 bit... just coded to prevent it's use. Good luck speeding things up if your using XL2016. paleontology, the simple matter that Ken referred to involves U creating a path for your image files to hang out, coding to create an picture of whatever range(s) and then placing/replacing your range picture files in whatever path U figured (maybe a specified folder would be good). Anyways, I hope that U have also appreciated Ken's extra learnin'. Good luck with this and thank you Ken. Dave
 
Last edited:
Upvote 0
Keep in mind that your range is huge and this is a copy based on actual range size and not a true size as in a partial screen print.

This chart method is not fully tested but should be close. In a Module:
Code: 
Sub Main()
  Dim wb As Workbook, ws As Worksheet
  
  For Each ws In Worksheets
    If Len(ws.Name) = 5 And IsNumeric(ws.Name) Then
      Set wb = SaveOBJasJPG(ws.Range("A1:AU36"), ThisWorkbook.Path & "\" & ws.Name & ".jpg", wb, False)
    End If
  Next ws
  
  If Not wb Is Nothing Then wb.Close False
End Sub

Sub Test_SaveObJasJPG()
  Dim wb As Workbook
  'Example use once call.
  Set wb = SaveOBJasJPG(Range("A1:C10"), ThisWorkbook.Path & "\SaveOBJasJPG.jpg")
End Sub

'obj can be a Range object, or a Shape object.
'jpg is drive:\path\filename.jpg filename to saveas jpg.
Function SaveOBJasJPG(obj, jpg$, Optional tWB As Workbook = Nothing, _
  Optional tfCloseTwb As Boolean = True) As Workbook
  
  Dim cht As Excel.ChartObject
  
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  Application.EnableEvents = False
  
  'Create temporaryscratch workbook if needed.
  If tWB Is Nothing Then Set tWB = Workbooks.Add(xlWBATWorksheet)
  
  'Make chart if needed and resize.
  ''Resize charts, https://peltiertech.com/Excel/ChartsHowTo/ResizeAndMoveAChart.html
  Set cht = tWB.Worksheets(1).ChartObjects.Add(0, 0, obj.Width, obj.Height)
  cht.Border.LineStyle = 0
  
  'Copy object, paste to chart, and save to jpg file.
  obj.CopyPicture xlScreen, xlPicture
  cht.Activate 'or cht.Select is required prior to paste.\
  cht.Chart.Paste
  cht.Chart.Export jpg, "jpg"
  cht.Delete
  
  Application.ScreenUpdating = True
  Application.EnableEvents = True
  Application.DisplayAlerts = True
  Application.CutCopyMode = False
  
  'Close temporary workbook without saving.
  If tfCloseTwb Then tWB.Close False
  'If not closed, return the workbook object for reuse, else return workbook as Nothing.
  Set SaveOBJasJPG = tWB
End Function
 
Last edited:
Upvote 0
As mentioned by Kenneth, the API method is much faster and cleaner and if you use the GDI+ built-in library , you can create smaller JPEG image files instead of large BMPs .

The GDI+ Class library is included with all versions of Windows from Windows XP.

Here is the code that saves to disk a worksheet range (or any other copieable graphic object) as a JPG image file :

1- In a Standard Module :
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
   Value As Long
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
    
    '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

    '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


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 = CLng(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
    
    On Error GoTo errHandler

    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
   
    If Err Then
      Err.Raise 5, , "Cannot Create Picture."
     End If
   
End Function


2- Code Usage exmaple :
Code: 
Sub Test()

    Call PicTureToJPGFile _
    ( _
            Pict:=CreatePicture(Sheet1.Range("A1:AU36")), _
            Filename:="C:\Test\RangeImage.jpg" _
    )

End Sub
 
Last edited:
  • Like
Reactions: ZVI
Upvote 0
Hi Jaafar,

Nice code, thank you for sharing!

But in my testing an overflow occurs in Excel 2016 64bit on this line:
.Value = CLng(VarPtr(Quality))
because of VarPtr(Quality) = 1667024682944 in my case

Fixing are as follows:
1. In structure EncodeParameter
Rich (BB code): 
Private Type EncoderParameter
   GUID As GUID
   NumberOfValues As Long
   Type As Long
   #If VBA7 Then
    Value As LongPtr
   #Else 
    Value As Long
   #End  If
End Type
2. In Sub PictureToJPGFile
Rich (BB code): 
         With tParams.Parameter
            CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
            .NumberOfValues = 1
            .Type = 4
            #If VBA7 Then
              .Value = VarPtr(Quality)
            #Else 
              .Value = CLng(VarPtr(Quality))
            #End  If
         End With

Best Regards,
Vlad
 
Upvote 0
I think we lost the op. In any case, this was a productive thread. Thanks for the API code Jaafar Tribak and ZVI. I incorporated the changes suggested and added a short routine.

Comparing file size for my limited test, it looks like 93 quality was about the same as the chart method.

Here is the 2nd Main that used the API routine.
Code: 
Sub Main2()
  Dim ws As Worksheet
  
  For Each ws In Worksheets
    If Len(ws.Name) = 5 And IsNumeric(ws.Name) Then
      'PicTureToJPGFile CreatePicture(ws.Range("A1:AU36")), ThisWorkbook.Path & "\" & ws.Name & ".jpg"  '100 quality default.
      'OBJtoJPGfile ws.Range("A1:AU36"), ThisWorkbook.Path & "\" & ws.Name & ".jpg" '100 quality default.
      OBJtoJPGfile ws.Range("A1:AU36"), ThisWorkbook.Path & "\" & ws.Name & ".jpg", 93 'similar to chart size.
    End If
  Next ws
End Sub

Here is the tweaked code for a separate Module:
Code: 
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
    
    '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

    '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


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
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA7 Then
              .Value = VarPtr(Quality)
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
              .Value = CLng(VarPtr(Quality))
            [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  If
         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
    
    On Error GoTo errHandler

    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
   
    If Err Then
      Err.Raise 5, , "Cannot Create Picture."
     End If
End Function

Sub OBJtoJPGfile(obj As Object, ByVal Filename As String, Optional ByVal Quality As Byte = 100)
  PicTureToJPGFile CreatePicture(obj), Filename, Quality
End Sub
 
Upvote 0
Kenneth Hobson said:
Comparing file size for my limited test, it looks like 93 quality was about the same as the chart method.
Click to expand...
Hi Kenneth,

Thanks for your code and the comparing VBA vs API file sizes.

My short testing for the small range A1:E6 shows that your Main creates picture:
400x144px 24 bit with uncompressed size =400*144*24/1024/8 = 168.8 kBytes

And the Jaafars' code creates picture:
401x145px 24 bit with uncompressed size =401*145*24/1024/8 = 170.3 kBytes

Here the 8 is anount of bits in a Byte.

So the difference is in size not in quality.

By the way in my practice using quality = 50% shrinks file size of JPG dramatically with almost invisible losing of its visual impression.

Best Regards,
Vlad
 
Last edited:
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Question Question
Take screenshots & simultaneously capture the link, place it into an Excel file which is linked to a FileMaker/Claris db.
Replies
3
Views
389
Dan_W
D
M
  • Question Question
Create new workbook for every sheet in active workbook, starting from Sheet(3) and saving them to a user specified folder location.
Replies
0
Views
995
Mars84
M
A
  • Question Question
First VBA Project - is there a better way to write this code?
Replies
0
Views
2K
akshay27
A
J
  • Question Question
Take Excel Worksheet, Divide into Worksheets/Workbooks by Employee/Card #, Email via Gmail to Employee for Input
Replies
9
Views
865
jennifer7i884
J
P
  • Question Question
Save certain worksheets as PDFs in a fluid location
Replies
3
Views
596
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,909
Messages
6,175,313
Members
452,634
Latest member
cpostell

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