1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
| '//////////////////////////////////////////////////////
' Auteurs et participants:
'rmist2024 : https://www.developpez.net/forums/u1843650/rmist2024/
'laurent_ott : https://www.developpez.net/forums/u683044/laurent_ott/
'jurassic-pork: https://www.developpez.net/forums/u273217/jurassic-pork/
'patmeziere : https://www.developpez.net/forums/u1838875/patmeziere/
' Alias patricktoulon
'Discussion:
'https://www.developpez.net/forums/d2169702/logiciels/microsoft-office/excel/macros-vba-excel/capture-d-ecran-usf-64-bit/#post12045083
'Capturer le userform avec les api sans passer par le clipboard
'dans cet exemple on print la fenêtre dans un HDC dynamique avec printwindow
'cette méthode offre l'avantage de ne pas avoir besoins que la fenetre soit visible a l'écran
'et de ne pas avoir a déterminer les coordonnées de la fenêtre en cas de multi ecrans
'creation de l'image avec gdi+ avec le CLISD correspondant au format voulu(png,jpg,gif,bmp)
'Attention le gif rend mal a ne pas utiliser
Option Explicit
Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As LongPtr) As LongPtr
Private Declare PtrSafe Function CreateDIBSection Lib "gdi32" (ByVal hdc As LongPtr, pBitmapInfo As BitmapInfo, ByVal un As Long, ByVal lplpVoid As LongPtr, ByVal handle As LongPtr, ByVal dw As Long) As LongPtr
Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hdc As LongPtr, ByVal hObject As LongPtr) As LongPtr
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function FindWindowA Lib "user32" (ByVal cls As String, ByVal cap As String) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, Rc As RECT) As Long
Private Declare PtrSafe Function PrintWindow Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr, ByVal flags As Long) As Long
Declare PtrSafe Function GetDesktopWindow Lib "user32" () As LongPtr
' GDI +
Private Declare PtrSafe Function GdipCreateBitmapFromHBITMAP Lib "gdiplus" (ByVal hbm As LongPtr, ByVal hPal As LongPtr, GBitmap As LongPtr) As Long
Private Declare PtrSafe Function GdipSaveImageToFile Lib "gdiplus" (ByVal GBitmap As LongPtr, ByVal Filename As LongPtr, ByVal pclsidEncoder As LongPtr, ByVal encoderParams As LongPtr) As Long
Private Declare PtrSafe Function GdipDisposeImage Lib "gdiplus" (ByVal GBitmap As LongPtr) As LongPtr
Private Declare PtrSafe Function GdiplusStartup Lib "gdiplus" (token As LongPtr, GInput As GdiplusStartupInput, ByVal Goutput As Long) As Long
Private Declare PtrSafe Function CLSIDFromString Lib "ole32" (ByVal str As LongPtr, ByVal pGuid As LongPtr) As Long
Private Type GdiplusStartupInput
GdiplusVersion As Long
DebugEventCallback As LongPtr
SuppressBackgroundThread As LongPtr
SuppressExternalCodecs As Long
End Type
Private Type RECT: Left As Long: Top As Long: Right As Long: Bottom As Long: End Type
Private Type BitmapInfo
biSize As Long: biWidth As Long: biHeight As Long: biPlanes As Integer
biBitCount As Integer: biCompression As Long: biSizeImage As Long
biXPelsPerMeter As Long: biYPelsPerMeter As Long: biRUsed As Long: biRImportant As Long
End Type
Sub ScreenFormCaptureToFile(Optional ByVal Usf As Object = Nothing, Optional ByVal aFilename As String = "")
Static gdiplusToken As LongPtr
Dim lngLargeur As Long, lngHauteur As Long
Dim bmiBitmapInfo As BitmapInfo
Dim lngHdc As LongPtr, lngHBmp As LongPtr, oldObj As LongPtr
Dim Wind As LongPtr, R As RECT
Dim StartupInput As GdiplusStartupInput
Dim Encoder(0 To 15) As Byte, GBitmap As LongPtr
Dim Format_GUID As String
Dim profondeur_color As Long
Select Case LCase(Mid(aFilename, InStrRev(aFilename, ".")))
Case ".png": Format_GUID = "{557CF406-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 32
Case ".gif": Format_GUID = "{557CF402-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 8
Case ".bmp": Format_GUID = "{557CF400-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 32
Case ".jpg", ".jpeg": Format_GUID = "{557CF401-1A04-11D3-9A73-0000F81EF32E}": profondeur_color = 32
End Select
If Usf Is Nothing Then
Wind = Application.hwnd
'GetDesktopWindow() 'printwindow deraille avec les fenêtre qui utilise l'accélération matérielle (directx openGL etc...)
Else
Wind = FindWindowA(vbNullString, Usf.Caption)
End If
If Wind = 0 Then Exit Sub
GetWindowRect Wind, R
lngLargeur = R.Right - R.Left
lngHauteur = R.Bottom - R.Top
With bmiBitmapInfo
.biBitCount = profondeur_color: .biCompression = 0&: .biPlanes = 1
.biSize = Len(bmiBitmapInfo): .biHeight = lngHauteur: .biWidth = lngLargeur
.biSizeImage = ((((.biWidth * .biBitCount) + 31) \ 32) * 4 - (((.biWidth * .biBitCount) + 7) \ 8)) * .biHeight
End With
lngHdc = CreateCompatibleDC(0)
lngHBmp = CreateDIBSection(lngHdc, bmiBitmapInfo, 0&, ByVal 0&, ByVal 0&, ByVal 0&)
oldObj = SelectObject(lngHdc, lngHBmp)
PrintWindow Wind, lngHdc, 0
If gdiplusToken = 0 Then
StartupInput.GdiplusVersion = 1
GdiplusStartup gdiplusToken, StartupInput, 0
End If
If GdipCreateBitmapFromHBITMAP(lngHBmp, 0, GBitmap) = 0 Then
CLSIDFromString StrPtr(Format_GUID), VarPtr(Encoder(0))
GdipSaveImageToFile GBitmap, StrPtr(aFilename), VarPtr(Encoder(0)), 0
GdipDisposeImage GBitmap
End If
oldObj = SelectObject(lngHdc, oldObj)
DeleteObject lngHBmp
DeleteObject lngHdc
End Sub |
Envoyé par patmeziere
Répondre avec citation
Partager