export shnapshot as PNG/JPG

[lusjash]

Hi guys.
My first post (until now google helped out)

So I want to save the snapshot of a portion of screen (not necessarily excel worksheet) to a file. So far I managed to save it to BMP. But files are too big.
Hence saving to JPG or even GIF is more preferable.

Here is the code I have (I got it from somewhere. Not sure I understand it thoroughly. I would appreciate If you could help me to strip it from unnecessary staf)




Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Const SRCCOPY = &HCC0020 ' (DWORD) destination = source

Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type

'API
Declare Function ReleaseDC Lib "user32.dll" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Declare Function OpenClipboard Lib "user32.dll" (ByVal hwnd As Long) As Long
Declare Function EmptyClipboard Lib "user32.dll" () As Long
Declare Function SetClipboardData Lib "user32.dll" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Declare Function GetClipboardData Lib "user32" (ByVal wFormat As Integer) As Long
Declare Function CloseClipboard Lib "user32.dll" () As Long
Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function BitBlt Lib "gdi32.dll" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As DEVMODE) As Long
Declare Function CreateCompatibleBitmap Lib "gdi32.dll" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As uPicDesc, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long
Declare Function CountClipboardFormats Lib "user32" () As Long
Declare Function IsClipboardFormatAvailable Lib "user32" (ByVal wFormat As Long) As Long
Declare Function CreateIC Lib "GDI32" Alias "CreateICA" _
(ByVal lpDriverName As String, ByVal lpDeviceName As String, _
ByVal lpOutput As String, lpInitData As Long) As Long
Declare Function GetDeviceCaps Lib "GDI32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat As Long) As Long

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

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
Public Sub ScreenToBMP_test()


Dim wbDest As Workbook, wsDest As Worksheet
Dim FromType As String, PicHigh As Single
Dim PicWide As Single, PicWideInch As Single
Dim PicHighInch As Single, DPI As Long
Dim PixelsWide As Integer, PixelsHigh As Integer

Dim IID_IDispatch As GUID
Dim uPicInfo As uPicDesc
Dim IPic As IPicture
Dim hPtr As Long
Dim flPath As String


ActiveWorkbook.Application.ScreenUpdating = False


Call GetPrintScreen
If CountClipboardFormats = 0 Then
'MsgBox "Clipboard is currently empty.", vbExclamation, "Nothing to Paste"
GoTo EndOfSub
End If
If IsClipboardFormatAvailable(14) <> 0 Then
FromType = "pic"
ElseIf IsClipboardFormatAvailable(2) <> 0 Then
FromType = "bmp"
Else
Exit Sub
End If

OpenClipboard 0
hPtr = GetClipboardData(CF_BITMAP)
CloseClipboard

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

With uPicInfo
.Size = Len(uPicInfo)
.Type = 1 ' PICTYPE_BITMAP
.hPic = hPtr
.hPal = 0
End With

OleCreatePictureIndirect uPicInfo, IID_IDispatch, True, IPic
SavePicture IPic, "d:\test.bmp"

EndOfSub:
ActiveWorkbook.Application.ScreenUpdating = True

End Sub


Sub GetPrintScreen()
Call CaptureScreen(100, 100, 200, 200)
End Sub

Many thanks in advance

 

[Comfy]

Have a search on Google for Gadwin Printscreen.

You can specify the area for the snapshot and either output as a file or add to the clipboard.

 

[lusjash]

Have a search on Google for Gadwin Printscreen.

You can specify the area for the snapshot and either output as a file or add to the clipboard.

thanks for reply, but this is a

Thanks for reply, but I cannot use external program. The code I presented is a part of bigger program, which "follows" changes on screen (it is triggered, when color changes at particular pixels), makes screenshots at particular time intervals, emails notification and screenshots, logs changes, etc.. This all is done in VBA. Hence I need BMP -> JPG conversion.

Any help in this direction is much appreciated

 

[Jaafar Tribak]

HERE is some open source code published on : codes-sources.commentcamarche.net .. Unzip the pack and copy the existing codes

The code is meant for VB6 but you should be able to adapt it easily for your VBA project requirements

Note: the Project uses a standard dll (as opposed to a COM dll) which means (contrary to what the author suggests !) you can use it without having to regitser it first.. Just make sure you explicitly qualify the full path to the dll when declaring the dll function exports
so :
Private Declare Function ijlInit Lib "ijl11.dll" (jcprops As Any) As Long
Becomes :
Private Declare Function ijlInit Lib "TheFullPathTotheDll\ijl11.dll" (jcprops As Any) As Long
and so on

Even better, for portability reasons, you could extract the Bytes from the ijl11.dl and store them on a hidden worksheet then every time you open your project you recreate the dll file and save it to disk on the fly using some code

 

[lusjash]

Thanks for guidance. Though I ended up using the converter here:

image - How to convert bmp to jpg in vb6 - Stack Overflow

In the link you provided JPG was converted after saving BMP too. I thought somehow to skip the BMP saving part.. I hope the conversion wouldn't be resource hog.

Thanks anyway