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
107
108
109
110
111
112
113
114
115
116
117
118
119
|
Option Explicit
' Definition des variables non typees en long pour 32 bits ou longptr pour 64 bits
' Les elements des types doivent etre types obligatoirement
#If VBA7 Then
DefLngPtr A - Z
Const PtrNull As LongPtr = 0
#Else
DefLng A-Z
Const PtrNull As Long = 0
#End If
#If VBA7 Then
Private Declare PtrSafe Function FindWindow Lib "USER32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As LongPtr
private Declare PtrSafe Function ClientToScreen Lib "user32" Alias "ClientToScreen" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function GetWindowRect Lib "USER32" (ByVal hwnd As LongPtr, lpRect As Rect) As Long
Private Declare PtrSafe Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As LongPtr
Private Declare PtrSafe Function CombineRgn Lib "gdi32" (ByVal hDestRgn As LongPtr, ByVal hSrcRgn1 As LongPtr, ByVal hSrcRgn2 As LongPtr, ByVal nCombineMode As Long) As Long
Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
Private Declare PtrSafe Function SetWindowRgn Lib "USER32" (ByVal hwnd As LongPtr, ByVal hRgn As LongPtr, ByVal bRedraw As Long) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function GetDC Lib "USER32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "USER32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetWindowRgn Lib "user32" Alias "GetWindowRgn" (ByVal hWnd As LongPtr, ByVal hRgn As LongPtr) As Long
Private Declare PtrSafe Function FindWindowEx Lib "USER32" Alias "FindWindowExA" (ByVal hWnd1 As LongPtr, ByVal hWnd2 As LongPtr, ByVal lpsz1 As String, ByVal lpsz2 As String) As LongPtr
#Else
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpsz1 As String, ByVal lpsz2 As String) As Long
Private Declare Function ClientToScreen Lib "user32" (ByVal hWnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
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 GetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn 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
#End If
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Const RGN_AND = 1
Private Const RGN_OR = 2
Private Const RGN_XOR = 3
Private Const RGN_DIFF = 4
Private Const RGN_COPY = 5
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const ERRORAPI = 0
Private Const NULLREGION = 1
Private Const SIMPLEREGION = 2
Private Const COMPLEXREGION = 3
' Fait un trou dans un formulaire
' Le trou est fait à l'emplacement des controls dans pControls
' Les contrôles doivent tous appartenir au même formulaire
' Ne fonctionne pas pour des contrôles dans un Frame
Public Function MakeHole(ParamArray pControls() As Variant) As Boolean
Dim lHwnd, lhDC
Dim lPt As POINTAPI
Dim lRect As RECT
Dim lDecalageX As Long, lDecalageY As Long
Dim lUserFormRegion, lRegionCtrl
Dim lpppX As Long, lpppY As Long
Dim lCpt As Long
' Handle du formulaire
lHwnd = FindWindow(vbNullString, pControls(0).Parent.Caption)
' Rectangle contenant le formulaire en coordonnées écran
GetWindowRect lHwnd, lRect
' Convertit 0,0 de la zone client en coordonnées écran
ClientToScreen lHwnd, lPt
' Décalage entre la zone client et la fenêtre userForm
lDecalageX = lPt.x - lRect.Left
lDecalageY = lPt.y - lRect.Top
' Recherche les points par pouce pour convertion points vers pixels
lhDC = GetDC(lHwnd)
lpppX = GetDeviceCaps(lhDC, LOGPIXELSX)
lpppY = GetDeviceCaps(lhDC, LOGPIXELSY)
ReleaseDC lHwnd, lhDC
' Région vide pour contenir le retour de GetWindowRgn
lUserFormRegion = CreateRectRgn(0, 0, 0, 0)
' Recherche une éventuelle région déjà affectée au formulaire
If GetWindowRgn(lHwnd, lUserFormRegion) < SIMPLEREGION Then
' Si pas de région => supprime la région temporaire
DeleteObject lUserFormRegion
' Et crée une région englobant tout le formulaire
lUserFormRegion = CreateRectRgn(0, 0, lRect.Right - lRect.Left, lRect.Bottom - lRect.Top)
End If
For lCpt = LBound(pControls) To UBound(pControls)
' Création d'une région englobant le contrôle pControl
' Il y a 72 points dans un pouce et pppX pixels dans un pouce
lRegionCtrl = CreateRectRgn(lDecalageX + pControls(lCpt).Left * lpppX / 72, _
lDecalageY + pControls(lCpt).Top * lpppY / 72, _
lDecalageX + (pControls(lCpt).Left + pControls(lCpt).Width) * lpppX / 72, _
lDecalageY + (pControls(lCpt).Top + pControls(lCpt).Height) * lpppY / 72)
' Combine les régions pour faire le trou
CombineRgn lUserFormRegion, lUserFormRegion, lRegionCtrl, RGN_DIFF
' Supprime la région temporaire
DeleteObject lRegionCtrl
Next
' Affecte la région au formulaire
' MakeHole renvoit True si l'affectation à la région s'est correctement déroulée
MakeHole = (SetWindowRgn(lHwnd, lUserFormRegion, 1) > 0)
' Supprime la région
DeleteObject lUserFormRegion
End Function |
