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
| Private Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "User32" () As Long
Private Declare Function CloseClipboard Lib "User32" () As Long
Private Declare Function SetClipboardData Lib "User32" (ByVal wFormat As Long, ByVal hMem As Long) As Long
Private Declare Function GetClipboardData& Lib "User32" (ByVal wFormat%)
Private Declare Function GetDC Lib "User32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "User32" (ByVal hwnd As Long, 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 Function CreateCompatibleDC Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal Hdc As Long, ByVal hObject As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (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
Private Declare Function GetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal x As Long, ByVal Y As Long) As Long
Private Declare Function SetPixel Lib "gdi32" (ByVal Hdc As Long, ByVal x As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal Hdc As Long) As Long
Private Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function GetForegroundWindow Lib "User32" () As Long
Private Declare Function GetDesktopWindow Lib "User32" () As Long
Private Declare Function GetActiveWindow Lib "User32" () As Long
Private Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long
' api creation object image
Private Declare Function CopyImage& Lib "User32" (ByVal handle&, ByVal un1&, ByVal n1&, ByVal n2&, ByVal un2&)
Private Declare Function IIDFromString Lib "ole32" (ByVal lpsz As String, ByRef lpiid As GUID) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32" (pPictDesc As PICTDESC, ByRef riid As GUID, ByVal fOwn As Long, ByRef ppvObj As IPicture) As Long
'rectangle
Type RECT: Left As Long: Top As Long: Right As Long: BOTTOM As Long: End Type
'guid all propertie pour le jpg
Type GUID: Data1 As Long: Data2 As Integer: Data3 As Integer: Data4(8) As Byte: End Type
' info image
Private Type PICTDESC: cbSize As Long: picType As Long: hImage As Long: End Type
Const SRCCOPY = &HCC0020
Public Chemin_Image As String
Public Chemin_Imagetemp As String
Public Mon_Usf As String
'******************************************************************
' La fonction qui suit sert à générer et sauvegarder ue image copie ecran d'un UserFrom.
' en cas de soucis contatcer PATRICKTOULON sur developpez.com
'*******************************************************************
Sub captur_USERFORM(usf)
Dim ActiveHwnd As Long, DeskHwnd As Long, Hdc As Long, hdcMem As Long, RECT As RECT, action As Long, fwidth As Long, fheight As Long
Dim hBitmap As Long, iPic As IPicture, hCopy&, tIID As GUID, tPICTDEST As PICTDESC, Ret As Long, Img As Object, IP As Object 'OBJECT!!!!! OBJECT!!!!!
'---------------------------------------------------
DeskHwnd = GetDesktopWindow(): ActiveHwnd = GetActiveWindow() ' determination du handle de la fentre active et du bureau
'---------------------------------------------------
'---------------------------------------------------
'determination du rectangle de capture avec les coordonnée de la fenetre active
Call GetWindowRect(ActiveHwnd, RECT)
fwidth = (RECT.Right - RECT.Left): fheight = (RECT.BOTTOM - RECT.Top)
'---------------------------------------------------
'---------------------------------------------------
' determination du contexte HDC du desktop et creation du bitmap avec son HDC
Hdc = GetDC(DeskHwnd)
hdcMem = CreateCompatibleDC(Hdc)
hBitmap = CreateCompatibleBitmap(Hdc, fwidth - 9, fheight - 30)
'---------------------------------------------------
If hBitmap <> 0 Then
SelectObject hdcMem, hBitmap
BitBlt hdcMem, 0, 0, fwidth - 9, fheight - 30, Hdc, RECT.Left + 4.5, RECT.Top + 30, SRCCOPY
'---------------------------------------------
' vidage et mise en memoire de l'image bitmap dans le clipboard
OpenClipboard 0: EmptyClipboard: SetClipboardData 2, hBitmap: CloseClipboard
'---------------------------------------------
End If
' SAUVEGARDE DE L IMAGE
Chemin_Imagetemp = Environ("userprofile") & "\Desktop\" & usf.Name & "temp.jpg"
Mon_Usf = usf.Name & ".jpg"
OpenClipboard 0&
hCopy = CopyImage(GetClipboardData(&H2), 0, 0, 0, &H8)
CloseClipboard
If hCopy = 0 Then Exit Sub
Const IPictureIID = "{7BF80981-BF32-101A-8BBB-00AA00300CAB}"
Ret = IIDFromString(StrConv(IPictureIID, vbUnicode), tIID)
If Ret Then Exit Sub
With tPICTDEST: .cbSize = Len(tPICTDEST): .picType = 1: .hImage = hCopy: End With
Ret = OleCreatePictureIndirect(tPICTDEST, tIID, 1, iPic)
If Ret Then Exit Sub
SavePicture iPic, Chemin_Imagetemp 'on enregistre le cliché
'---------------------------------------------
' Clean up handles
DeleteDC hdcMem: ReleaseDC DeskHwnd, Hdc
'---------------------------------------------
Set Img = CreateObject("WIA.ImageFile") 'Création conteneur pour l'image à manipuler
Set IP = CreateObject("WIA.ImageProcess") 'Création du gestionnaire de filtre
Img.LoadFile Chemin_Imagetemp 'Chargement de l'image dans le conteneur
With IP.Filters
.Add IP.FilterInfos("Convert").FilterID
.Item(1).Properties("FormatID").Value = "{B96B3CAE-0728-11D3-9D7B-0000F81EF32E}" 'c'est la constante ""wiaFormatJPEG"" en late biding
.Item(1).Properties("Quality").Value = 100
'Application du filtre à l'image
Set Img = IP.Apply(Img)
End With
'Enregistre l'image redimensionnée
If Dir(Replace(Chemin_Imagetemp, "temp", "")) <> "" Then Kill Replace(Replace(Chemin_Imagetemp, "temp", ""), "bipmap", "jpg")
Img.SaveFile Replace(Chemin_Imagetemp, "temp", "")
'Kill Chemin_Imagetemp
End Sub |
re
: ça peut servir aux autres 
Répondre avec citation
Partager