I found this macro online and need to understand a bit more about how it works...
The dimensions of the png image being created are too big for another software I use which is limited to 1920x1080
Is there a way to control the image dimension in this code?
The dimensions of the png image being created are too big for another software I use which is limited to 1920x1080
Is there a way to control the image dimension in this code?
Code:
Option Explicit
Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" _
(PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, _
IPic As IPicture) As Long
'\\ Declare a UDT to store a GUID for the IPicture OLE Interface
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type
'\\ Declare a UDT to store the bitmap information
Private Type uPicDesc
Size As Long
Type As Long
hPic As Long
hPal As Long
End Type
Private Const CF_BITMAP = 2
Private Const PICTYPE_BITMAP = 1
Private Sub SaveRangePic(SourceRange As Range, FilePathName As String)
Dim IID_IDispatch As GUID
Dim uPicinfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
'\\ Copy Range to ClipBoard
SourceRange.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard
'\\ Create the interface GUID for the picture
With IID_IDispatch
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'\\ Fill uPicInfo with necessary parts.
With uPicinfo
.Size = Len(uPicinfo) '\\ Length of structure.
.Type = PICTYPE_BITMAP '\\ Type of Picture
.hPic = hPtr '\\ Handle to image.
.hPal = 0 '\\ Handle to palette (if bitmap).
End With
'\\ Create the Range Picture Object
OleCreatePictureIndirect uPicinfo, IID_IDispatch, True, IPic
'\\ Save Picture Object
stdole.SavePicture IPic, FilePathName
Application.CutCopyMode = False
'OpenClipboard 0
'EmptyClipboard
'CloseClipboard
End Sub
Sub Images()
Dim TARGET As String
TARGET = "C:\Users\KennyS\Desktop\Kenny\5A2 RH5\DISPLAY"
SaveRangePic Sheet11.Range("A2:AA52"), TARGET & "\AL CHARTS.png"
SaveRangePic Sheet11.Range("A53:AA103"), TARGET & "\AL CHARTS2.png"
SaveRangePic Sheet11.Range("A104:AA154"), TARGET & "\AL CHARTS3.png"
SaveRangePic Sheet11.Range("A155:AA205"), TARGET & "\AL CHARTS4.png"
SaveRangePic Sheet19.Range("A2:AA52"), TARGET & "\AR CHARTS.png"
SaveRangePic Sheet19.Range("A53:AA103"), TARGET & "\AR CHARTS2.png"
SaveRangePic Sheet19.Range("A104:AA154"), TARGET & "\AR CHARTS3.png"
SaveRangePic Sheet19.Range("A155:AA205"), TARGET & "\AR CHARTS4.png"
SaveRangePic Sheet14.Range("A2:AA52"), TARGET & "\BL CHARTS.png"
SaveRangePic Sheet14.Range("A53:AA103"), TARGET & "\BL CHARTS2.png"
SaveRangePic Sheet14.Range("A104:AA154"), TARGET & "\BL CHARTS3.png"
SaveRangePic Sheet14.Range("A155:AA205"), TARGET & "\BL CHARTS4.png"
SaveRangePic Sheet15.Range("A2:AA52"), TARGET & "\BR CHARTS.png"
SaveRangePic Sheet15.Range("A53:AA103"), TARGET & "\BR CHARTS2.png"
SaveRangePic Sheet15.Range("A104:AA154"), TARGET & "\BR CHARTS3.png"
SaveRangePic Sheet15.Range("A155:AA205"), TARGET & "\BR CHARTS4.png"
End Sub