Code:
Option Explicit
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type POINTAPI
x As Long
y As Long
End Type
Public Enum PrintWindowFlag
PW_WINDOWSONLY = 0 ''???
'"Only the client area of the window is copied to hdcBlt. By default, the entire window is copied.")]
PW_CLIENTONLY = &H1 '?????
'("works on windows that use DirectX or DirectComposition")]
PW_RENDERFULLCONTENT = &H2
End Enum
Public Declare Function GetClientRect _
Lib "user32" (ByVal hWnd As Long, _
lpRect As RECT) As Long '
Public Declare Function MapWindowPoints _
Lib "user32" (ByVal hwndFrom As Long, _
ByVal hwndTo As Long, _
lpPoint As POINTAPI, _
ByVal cPoints As Long) As Long '
'?????????????????????????
Public Declare Function GetWindowRect _
Lib "user32" (ByVal hWnd As Long, _
ByRef lpRect As RECT) As Long '
'////////////////////////////////// API \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\
Private Declare Function PrintWindow _
Lib "user32.dll" (ByVal hWnd As Long, _
ByVal hdcBlt As Long, _
ByVal nFlags As Long) As Long
Private Declare Function IsWindowVisible Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetParent Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function GetWindowLong _
Lib "user32.dll" _
Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal nIndex As Long) As Long
Private Declare Function GetWindowText _
Lib "user32.dll" _
Alias "GetWindowTextA" (ByVal hWnd As Long, _
ByVal lpString As String, _
ByVal cch As Long) As Long
Private Declare Function GetWindow _
Lib "user32.dll" (ByVal hWnd As Long, _
ByVal wCmd As Long) As Long
Private Declare Function GetDesktopWindow Lib "user32.dll" () As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" (ByVal hWnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) As Long
Private Declare Function OleCreatePictureIndirect _
Lib "olepro32.dll" (PicDesc As PicBmp, _
RefIID As GUID, _
ByVal fPictureOwnsHandle As Long, _
iPic As IPicture) As Long
Private Declare Function ReleaseDC _
Lib "user32.dll" (ByVal hWnd As Long, _
ByVal hdc As Long) As Long
Private Declare Function GetWindowDC Lib "user32.dll" (ByVal hWnd As Long) As Long
Private Declare Function CreateCompatibleBitmap _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nWidth As Long, _
ByVal nHeight As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
'Private Declare Function GetWindowRect Lib "user32.dll" (ByVal hwnd As Long, ByRef lpRect As RECT) As Long
Private Declare Function SetBkMode _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nBkMode As Long) As Long
Private Declare Function SelectObject _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function RedrawWindow _
Lib "user32.dll" (ByVal hWnd As Long, _
ByRef lprcUpdate As Any, _
ByVal hrgnUpdate As Long, _
ByVal fuRedraw As Long) As Long
Private Const RDW_INVALIDATE As Long = &H1
Private Const RDW_ERASENOW As Long = &H200
Private Const RDW_ALLCHILDREN As Long = &H80
Private Const RDW_UPDATENOW As Long = &H100
Private Const TRANSPARENT As Long = 1
Private Const RC_PALETTE As Long = &H100
Private Const SIZEPALETTE As Long = 104
Private Const RASTERCAPS As Long = 38
Private Const GW_CHILD As Long = 5
Private Const GW_OWNER As Long = 4
Private Const GW_HWNDNEXT As Long = 2
Private Const GWL_EXSTYLE As Long = -20
Private Const WS_EX_TOOLWINDOW As Long = &H80&
Private Const WS_EX_APPWINDOW As Long = &H40000
Private Const SW_SHOWNORMAL As Long = 1
Private Type PALETTEENTRY
peRed As Byte
peGreen As Byte
peBlue As Byte
peFlags As Byte
End Type
Private Type LOGPALETTE
palVersion As Integer
palNumEntries As Integer
palPalEntry(255) As PALETTEENTRY
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Type PicBmp
Size As Long
Type As Long
HBmp As Long
hPal As Long
Reserved As Long
End Type
'Private Type RECT
' Left As Long
' Top As Long
' Right As Long
' Bottom As Long
'End Type
Dim HBmp As Long
'****************************************************************************
Private Declare Function EnumClipboardFormats Lib "user32" (ByVal wFormat 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 ChangeClipboardChain _
Lib "user32" (ByVal hWnd As Long, _
ByVal hWndNext As Long) As Long
Private Declare Function CountClipboardFormats 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 GetClipboardFormatName _
Lib "user32" _
Alias "GetClipboardFormatNameA" (ByVal wFormat As Long, _
ByVal lpString As String, _
ByVal nMaxCount As Long) As Long
Private Declare Function GetClipboardOwner Lib "user32" () As Long
Private Declare Function GetClipboardViewer Lib "user32" () As Long
Private Declare Function GetOpenClipboardWindow Lib "user32" () As Long
Private Declare Function GetPriorityClipboardFormat _
Lib "user32" (lpPriorityList As Long, _
ByVal nCount As Long) As Long
Private Declare Function IsClipboardFormatAvailable _
Lib "user32" (ByVal wFormat As Long) As Long
Private Declare Function RegisterClipboardFormat _
Lib "user32" _
Alias "RegisterClipboardFormatA" (ByVal lpString As String) As Long
Private Declare Function SetClipboardData _
Lib "user32" (ByVal wFormat As Long, _
ByVal hMem As Long) As Long
Private Declare Function SetClipboardViewer Lib "user32" (ByVal hWnd As Long) As Long
' Global Memeory API
Private Const GMEM_DISCARDED = &H4000
Private Const GMEM_MOVEABLE = &H2
Private Declare Function GlobalAlloc _
Lib "kernel32" (ByVal wFlags As Long, _
ByVal dwBytes As Long) As Long
Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalSize Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFlags Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long
Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long
Private Const CF_BITMAP = 2
'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
DebugEventCallback As Long
SuppressBackgroundThread As Long
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
Private Declare Function GdiplusStartup _
Lib "gdiplus" (Token As Long, _
inputbuf As GdiplusStartupInput, _
ByVal outputbuf As Long) As Long
Private Declare Function GdiplusShutdown Lib "gdiplus" (ByVal Token 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
Private Declare Function GdipCreateBitmapFromHBITMAP _
Lib "gdiplus" (ByVal hbm As Long, _
ByVal hPal As Long, _
BITMAP As Long) As Long
'****************************************************************************
Private Declare Function FindWindow _
Lib "user32" _
Alias "FindWindowA" (ByVal lpclassname As String, _
ByVal lpWindowName As String) As Long '
Private Declare Function GetForegroundWindow Lib "user32" () As Long '
Private Declare Function GetCurrentObject _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal uObjectType As Long) As Long
Private Const SRCCOPY = &HCC0020
'Private Declare Function GetDIBits Lib "gdi32" (ByVal aHDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
'Private Declare Function GetWindowRect Lib "user32.dll" '(ByVal hwnd As Long, ByRef lpRect As rect) As Long
Private Declare Function StretchBlt _
Lib "gdi32" (ByVal hdc 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 nSrcWidth As Long, _
ByVal nSrcHeight As Long, _
ByVal dwRop As Long) As Long
'Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
'Private Declare Function PrintWindow Lib "user32" '(ByVal hwnd As Long, ByVal hdcBlt As Long, ByVal nFlags As Long) As Long
'Private Declare Function SelectObject Lib "gdi32" '(ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hWnd As Long) As Long
'Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
'Private Declare Function CreateCompatibleBitmap Lib "gdi32" '(ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Sub CopyMemory _
Lib "kernel32" _
Alias "RtlMoveMemory" (Destination As Any, _
Source As Any, _
ByVal Length As Long)
'Private Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function FindWindowEx _
Lib "user32" _
Alias "FindWindowExA" (ByVal hWnd1 As Long, _
ByVal hWnd2 As Long, _
ByVal lpsz1 As String, _
ByVal lpsz2 As String) As Long
'Private Declare Sub Sleep Lib "kernel32.dll" (ByVal dwMilliseconds As Long)
Private Declare Function MsgBoxEx _
Lib "user32" _
Alias "MessageBoxTimeoutA" (ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As VbMsgBoxStyle, _
ByVal wlange As Long, _
ByVal dwTimeout As Long) As Long
'————————————————
Private Declare Function SetStretchBltMode _
Lib "gdi32.dll" (ByVal hdc As Long, _
ByVal nStretchMode As Long) As Long
Private Const STRETCH_HALFTONE As Long = 4
'//https://www.vbforums.com/showthread.php?503405-RESOLVED-picturebox-upsidedown-gradient&p=3101827&viewfull=1#post3101827
Public Enum RedrawFlags
NoRedraw = 0
Redrawed = 1
RedrawAndSleep = 2
End Enum
Public Enum PrintWindowFlag
PW_WINDOWSONLY = 0 ''???
'"Only the client area of the window is copied to hdcBlt. By default, the entire window is copied.")]
PW_CLIENTONLY = &H1 '?????
'("works on windows that use DirectX or DirectComposition")]
PW_RENDERFULLCONTENT = &H2
End Enum
Public Function PringWindowsToMem(hwndTarget As Long, _
Optional nFlag As PrintWindowFlag = PW_WINDOWSONLY, _
Optional mRedrawWindow As RedrawFlags) As Long
Dim hDCWnd As Long
Dim hdcMem As Long '????
Dim hBmpOld As Long
Dim wndWid As Integer
Dim wndHei As Integer
Dim wndRect As RECT
Dim lRet As Long
Dim appIndex As Integer
Call GetWindowRect(hwndTarget, wndRect) '??????
wndWid = (wndRect.Right - wndRect.Left)
wndHei = (wndRect.Bottom - wndRect.Top)
If ((wndWid <> 0) And (wndHei <> 0)) Then
hDCWnd = GetDC(hwndTarget) ' GetWindowDC(hwndTarget) '??DC
hdcMem = CreateCompatibleDC(hDCWnd) '??dc????
HBmp = CreateCompatibleBitmap(hDCWnd, wndWid, wndHei) '????
Call ReleaseDC(hwndTarget, hDCWnd) '
hBmpOld = SelectObject(hdcMem, HBmp) '
Call SetBkMode(hdcMem, TRANSPARENT) '
End If
If HBmp = 0 Then
MsgBox "ERROR ??????"
PringWindowsToMem = 0
Exit Function
End If
'??1.
Select Case mRedrawWindow
Case 0
lRet = PrintWindow(hwndTarget, hdcMem, 0)
'??2
Case 1
Call RedrawWindow(hwndTarget, ByVal 0, ByVal 0, RDW_INVALIDATE Or RDW_ALLCHILDREN Or RDW_UPDATENOW)
lRet = PrintWindow(hwndTarget, hdcMem, 0)
Case 2
'??3:
Call RedrawWindow(hwndTarget, ByVal 0, ByVal 0, RDW_INVALIDATE Or RDW_ALLCHILDREN Or RDW_UPDATENOW)
Call Sleep(100)
lRet = PrintWindow(hwndTarget, hdcMem, 0)
End Select
HBmp = SelectObject(hdcMem, hBmpOld) '
PringWindowsToMem = HBmp
Call DeleteDC(hdcMem)
'call CleanHdcMem
Debug.Print " PringWindowsToMem"
End Function
'
Public Function CleanHBmp(Optional mHBmp As Long = 0)
If mHBmp = 0 Then
Call DeleteObject(HBmp)
HBmp = 0
Else
DeleteObject (mHBmp)
mHBmp = 0
End If
End Function
'Call SavePicture(getStdPictureFromHBmp(hBmp), CreadFloder + "\" + Format(i, "00") + ".bmp")
'
Public Function GetStdPictureFromHBmp(ByVal mHBmp As Long) As StdPicture
Dim R As Long, Pic As PicBmp, iPic As IPicture, IID_IDispatch As GUID
' GUID
With IID_IDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Fill picture info
With Pic
.Size = Len(Pic) ' Length of structure
.Type = vbPicTypeBitmap ' Type of Picture (bitmap)
.HBmp = mHBmp ' Handle to bitmap
.hPal = 0 ' Handle to palette (may be null)
End With
' Create the picture
' R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, iPic)
' Return the new picture
' Set GetStdPictureFromHBmp = iPic
R = OleCreatePictureIndirect(Pic, IID_IDispatch, 1, GetStdPictureFromHBmp)
If R <> 0 Then
DeleteObject mHBmp '
Err.Raise R, "ModPrintWindowTohDCMem", "OleCreatePictureIndirect() error 0x" & Hex$(R)
End If
Debug.Print "mHBmp GetStdPictureFromHBmp"
End Function
'?????
Public Function CreadFloder() As String
Dim szFile As String
Dim fldr As String
fldr = App.Path + IIf((Right(App.Path, 1) = "\"), "", "\") + "Pictures"
If (Dir(fldr, vbDirectory) = "") Then
Call MkDir(fldr)
Else
szFile = Dir(fldr + "\*.bmp", vbNormal)
Do While (szFile <> "")
Call Kill(fldr + "\" + szFile)
szFile = Dir()
Loop
End If
CreadFloder = fldr
End Function
'
'
Public Function PrintWindowAndCrop(ByVal hWnd As Long, _
Optional nFlag As PrintWindowFlag = PW_WINDOWSONLY, _
Optional ByVal cropLeft As Integer = 0, _
Optional ByVal cropTop As Integer = 0, _
Optional ByVal cropRight As Integer = 0, _
Optional ByVal cropBottom As Integer = 0, _
Optional ByVal IsSetToClipboard As Boolean = False) As Long
'Dump the screen of specified form and save to clipboard.
'hWnd is the handle of target form, croptop/cropbottom/cropleft/cropright are pixels to crop, 0 by default means no crop.
'Return string message
Dim hdcMem As Long '
Dim hBmpOld As Long
Dim UserFormHwnd As Long, DeskHwnd As Long
Dim hdc As Long
Dim hdcMemc As Long, sMode As Long, hBitmap As Long
Dim hBitmapc As Long
Dim RECT As RECT
Dim RetVal As Long
Dim fwidth As Long, fheight As Long
Dim isCrop As Boolean
If cropTop < 0 Or cropBottom < 0 Or cropLeft < 0 Or cropRight < 0 Then
PrintWindowAndCrop = 0
Debug.Print "0-Wrong parameter"
Exit Function
End If
If cropTop > 0 Or cropBottom > 0 Or cropLeft > 0 Or cropRight > 0 Then
isCrop = True
End If
' Get window handle
DeskHwnd = 0 'GetDesktopWindow()
UserFormHwnd = hWnd
' Get screen coordinates
Call GetWindowRect(UserFormHwnd, RECT)
fwidth = RECT.Right - RECT.Left
fheight = RECT.Bottom - RECT.Top
' Get the device context of Desktop and allocate memory
hdc = GetDC(DeskHwnd)
hdcMem = CreateCompatibleDC(hdc)
hBitmap = CreateCompatibleBitmap(hdc, fwidth, fheight)
RetVal = ReleaseDC(DeskHwnd, hdc)
If hBitmap <> 0 Then
hBmpOld = SelectObject(hdcMem, hBitmap)
'Redraw window before capture
'RedrawWindow UserFormHwnd, ByVal 0, ByVal 0, RDW_INVALIDATE Or RDW_ALLCHILDREN Or RDW_UPDATENOW
' Copy bitmap to memory location
RetVal = PrintWindow(UserFormHwnd, hdcMem, nFlag)
'Crop image
If isCrop = True Then
fwidth = (cropRight - cropLeft)
fheight = (cropBottom - cropTop)
'Allocate memory for cropped image
hdc = GetDC(DeskHwnd)
hdcMemc = CreateCompatibleDC(hdc)
hBitmapc = CreateCompatibleBitmap(hdc, fwidth, fheight)
RetVal = ReleaseDC(DeskHwnd, hdc)
hBmpOld = SelectObject(hdcMemc, hBitmapc)
' copy flipped source to destination, offset for borders
sMode = SetStretchBltMode(hdcMemc, STRETCH_HALFTONE) ' makes stretching better quality
Call StretchBlt(hdcMemc, 0, 0, fwidth, fheight, hdcMem, cropLeft, cropTop, fwidth, fheight, SRCCOPY)
SetStretchBltMode hdcMemc, sMode ' reset stretchmode
If IsSetToClipboard = True Then
'Set up the Clipboard and copy bitmap
RetVal = OpenClipboard(DeskHwnd)
RetVal = EmptyClipboard()
RetVal = SetClipboardData(CF_BITMAP, hBitmapc)
RetVal = CloseClipboard()
End If
hBitmapc = SelectObject(hdcMemc, hBmpOld) '
HBmp = hBitmapc
'Clean up
RetVal = DeleteDC(hdcMemc)
RetVal = DeleteDC(hdcMem)
RetVal = DeleteObject(hBitmap)
Else
'Set up the Clipboard and copy bitmap
RetVal = OpenClipboard(DeskHwnd)
RetVal = EmptyClipboard()
RetVal = SetClipboardData(CF_BITMAP, hBitmap)
RetVal = CloseClipboard()
' retval = ReleaseDC(DeskHwnd, hdc)
hBitmap = SelectObject(hdcMem, hBmpOld) '
HBmp = hBitmap
RetVal = DeleteDC(hdcMem)
''retval = DeleteObject(hBitmap)
End If
'Debug.Print "1-Success"
Else
PrintWindowAndCrop = 0
Debug.Print "2-No bitmap"
End If
' Clean up
PrintWindowAndCrop = HBmp
Debug.Print " PrintWindowAndCrop"
End Function
Public Function CliptoJPG(ByVal destfilename As String, _
Optional ByVal quality As Byte = 80) As Integer
Dim tSI As GdiplusStartupInput
Dim lRes As Long
Dim lGDIP As Long
Dim lBitmap As Long
Dim HBmp As Long
'???????
If OpenClipboard(0) Then
'?????????????
HBmp = GetClipboardData(CF_BITMAP)
'??hBmp?0?????????????
If HBmp = 0 Then
CliptoJPG = 2
CloseClipboard
Exit Function
End If
CloseClipboard
Else '??openclipboard??0(False)??????????????
CliptoJPG = 3
Exit Function
End If
'??? GDI+
tSI.GdiplusVersion = 1
lRes = GdiplusStartup(lGDIP, tSI, 0)
If lRes = 0 Then
'????? GDI+ ??
lRes = GdipCreateBitmapFromHBITMAP(HBmp, 0, lBitmap)
If lRes = 0 Then
Dim tJpgEncoder As GUID
Dim tParams As EncoderParameters
'???????GUID??
CLSIDFromString StrPtr("{557CF401-1A04-11D3-9A73-0000F81EF32E}"), tJpgEncoder
'???????
tParams.Count = 1
With tParams.Parameter ' Quality
'??Quality???GUID??
CLSIDFromString StrPtr("{1D5BE4B5-FA4A-452D-9CDD-5DB35105E7EB}"), .GUID
.NumberOfValues = 1
.Type = 4
.Value = VarPtr(quality)
End With
'????
lRes = GdipSaveImageToFile(lBitmap, StrPtr(destfilename), tJpgEncoder, tParams)
If lRes = 0 Then
CliptoJPG = 0 '????
Else
CliptoJPG = 1 '????
End If
'??GDI+??
GdipDisposeImage lBitmap
End If
'?? GDI+
GdiplusShutdown lGDIP
End If
End Function
'