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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
| '---------------------------------------------------------------------------------------
' Module : modPipette
' Auteur : fred65200 - Frédéric CHAPIN - http://www.developpez.net/forums/f542/hardware-systemes-logiciels/microsoft-office/excel/
' Date : 26/02/2009
' Description : Obtention des codes RGB des couleurs sous le curseur de la souris
' Création d'un userform. Fermeture du classeur nécessaire la première fois.
' Affichage du UserForm "ufPipette" par la macro AfficherUSF.
' La fenêtre apparait toujours au premier plan, possibilité de naviguer
' entre les fenêtres ouvertes.
' Fermeture de la fenêtre par raccourcis Alt + F.
' Code RGB dans le presse papier.
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
' Activation de la référence Microsoft Visual Basic for Applications Extensibility nécessaire
'---------------------------------------------------------------------------------------
'---------------------------------------------------------------------------------------
'Option Explicit
'Obtention du Hwnd du UserForm
Declare Function FindWindow Lib "user32" Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
'Modifie la taille, position et ZOrder d'une fenêtre
Public Declare Function SetWindowPos Lib "user32" ( _
ByVal hwnd As Long, _
ByVal hWndInsertAfter As Long, _
ByVal x As Long, _
ByVal y As Long, _
ByVal cx As Long, _
ByVal cy As Long, _
ByVal wFlags As Long) As Long
Public Const SWP_NOMOVE = 2
Public Const SWP_NOSIZE = 1
Public Const FLAGS = SWP_NOMOVE Or SWP_NOSIZE
Public Const HWND_TOPMOST = -1
Public Const HWND_NOTOPMOST = -2
'Transmition des informations du message à la procédure de fenêtre spécifiée.
Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" ( _
ByVal lpPrevWndFunc As Long, _
ByVal hwnd As Long, _
ByVal Msg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
'Ajoute d'une chaîne de caractères à la "table atome" et
'renvoie une valeur unique (un atome) identifiant la chaîne.
Declare Function GlobalAddAtom Lib "kernel32" Alias "GlobalAddAtomA" ( _
ByVal lpString As String) As Integer
'Récupération des messages envoyés à la fenêtre
Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" ( _
ByVal hwnd As Long, _
ByVal nIndex As Long, _
ByVal dwNewLong As Long) As Long
'Ajout raccourcis clavier
Declare Function RegisterHotKey Lib "user32" (ByVal hwnd As Long, _
ByVal id As Long, _
ByVal fsModifiers As Long, _
ByVal vk As Long) As Long
'Suppression du raccourcis clavier
Declare Function UnregisterHotKey Lib "user32" (ByVal hwnd As Long, _
ByVal id As Long) As Long
' Modificateurs Alternate, Control, Shift
Public Const MOD_ALT = &H1
Public Const MOD_CONTROL = &H2
Public Const MOD_SHIFT = &H4
Public Const GWL_WNDPROC = -4
Public Const WM_HOTKEY = &H312
Public PrevWndProc As Long
'Création d'un timer avec la valeur de délai d'expiration spécifié.
Private Declare Function SetTimer Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimerFunc As Long) As Long
'Destruction du compteur spécifié
Private Declare Function KillTimer Lib "user32" ( _
ByVal hwnd As Long, _
ByVal nIDEvent As Long) As Long
'Obtention de la couleur du pixel spécifié
Private Declare Function GetPixel Lib "gdi32" ( _
ByVal hDC As Long, _
ByVal x As Long, _
ByVal y As Long) As Long
'Récupération un handle vers un contexte de périphérique (DC)
'pour la zone cliente de la zone spécifiée
Private Declare Function GetDC Lib "user32" ( _
ByVal hwnd As Long) As Long
'Récupération la position du curseur, en coordonnées d'écran
Private Declare Function GetCursorPos Lib "user32" ( _
lpPoint As POINTAPI) As Long
Private Type POINTAPI
x As Long
y As Long
End Type
Dim monTimer As Long
Public R As Byte, G As Byte, B As Byte
Public AppId As Long
Public lResult As Long
'Affichage du UserForm
Sub AfficherUSF()
'Vérification de la présence du UserForm dans le projet
If Not VBComponentExists("ufPipette", ThisWorkbook.VBProject) Then
'Pas trouvé d'autre alternative que la fermeture du classeur
MsgBox "Création d'un UserForm." & vbLf & "Redémarrage nécessaire."
'Création du UserForm
NewUserForm
ThisWorkbook.Close , True
End If
ufPipette.Show 0
End Sub
'Récupération du hWnd d'Excel
Function hwnd() As Long
hwnd = FindWindow(vbNullString, Application.Caption)
End Function
'Récupération du hWnd du UserForm
Function hWndForm() As Long
hWndForm = FindWindow("Thunder" & IIf(Application.Version Like "8*", _
"X", "D") & "Frame", ufPipette.Caption)
End Function
'Initialisarion du timer
Public Sub Init(Interval&)
monTimer = SetTimer(0, 0, Interval, AddressOf TimerProc)
End Sub
'Destruction du timer
Public Sub Terminate()
Call KillTimer(0, monTimer)
End Sub
'La fonction TimerProc traite les messages WM_TIMER (Msg&).
Private Sub TimerProc(ByVal hwnd&, ByVal Msg&, ByVal idEvent&, ByVal dwTime&)
Dim hDC As Long
Dim lpPoint As POINTAPI
Dim bColor As Long
On Error Resume Next
'Position du curseur
GetCursorPos lpPoint
hDC = GetDC(0)
'Obtention du code RGB
With ufPipette
DoEvents
.Image1.BackColor = GetPixel(hDC, lpPoint.x, lpPoint.y)
bColor = .Image1.BackColor 'Couleur inversée 16777215 - bColor
R = Int((bColor) / 256 ^ 0) Mod 256 ': invR = 255 - R 'RGB Inversé
G = Int((bColor) / 256 ^ 1) Mod 256 ': invG = 255 - G 'RGB Inversé
B = Int((bColor) / 256 ^ 2) Mod 256 ': invB = 255 - B 'RGB Inversé
.RVB = "RGB(Red:=" & R & ", Green:=" & G & ", Blue:=" & B & ")"
End With
End Sub
'Copie dans le presse-papier
Sub Copier()
Debug.Print bColor
Dim MyData As DataObject
Set MyData = New DataObject
MyData.SetText ufPipette.RVB
MyData.PutInClipboard
End Sub
'Traitement des messages envoyés à une fenêtre
Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, _
ByVal wParam As Long, ByVal lParam As Long) As Long
If uMsg = WM_HOTKEY Then
Call Terminate
Call Copier
Unload ufPipette
Else
' on traite les autres messages normalement
WindowProc = CallWindowProc(PrevWndProc, hwnd, uMsg, wParam, lParam)
End If
End Function
'Met une fenêtre toujours en avant plan ou comme une fenêtre normale,
'basée sur les deux paramètres hwnd et Topmost
Function SetTopMostWindow(hwnd As Long, Topmost As Boolean) As Long
If Topmost = True Then 'Make the window topmost
SetTopMostWindow = SetWindowPos(hwnd, HWND_TOPMOST, 0, 0, 0, 0, FLAGS)
Else
SetTopMostWindow = SetWindowPos(hwnd, HWND_NOTOPMOST, 0, 0, 0, 0, FLAGS)
SetTopMostWindow = False
End If
End Function
'Vérifie l'existence d'un VBcomponent
Public Function VBComponentExists(VBCompName As String, Optional VBProj As VBIDE.VBProject = Nothing) As Boolean
Dim VBP As VBIDE.VBProject
If VBProj Is Nothing Then
Set VBP = ActiveWorkbook.VBProject
Else
Set VBP = VBProj
End If
On Error Resume Next
VBComponentExists = CBool(Len(VBP.VBComponents(VBCompName).Name))
If Err.Number <> 0 Then Err.Clear: On Error GoTo 0
End Function
'Référence Microsoft Visual Basic for Applications Extensibility
Sub NewUserForm()
Dim newCtrl As Control
Dim strCode As String
Dim uftemp As VBComponent
'Création du UserForm
Set uftemp = ThisWorkbook.VBProject.VBComponents.Add(vbext_ct_MSForm)
With uftemp
.Properties("Name") = "ufPipette"
.Properties("Caption") = "Couleurs RGB"
.Properties("Width") = 222
.Properties("Height") = 117
End With
'Ajout du contrôle Image
Set newCtrl = uftemp.Designer.Controls.Add("forms.image.1")
With newCtrl
.Height = 42: .Left = 6: .Top = 6: .Width = 204
End With
'Ajout du Label RVB
Set newCtrl = uftemp.Designer.Controls.Add("forms.label.1")
With newCtrl
.Name = "RVB": .TextAlign = 2 'fmTextAlignCenter
.Height = 16: .Left = 6: .Top = 54: .Width = 204
End With
'Ajout du Label
Set newCtrl = uftemp.Designer.Controls.Add("forms.label.1")
With newCtrl
.Caption = "Alt + F pour copier le code RGB et fermer cette fenêtre."
.TextAlign = 2
.Height = 12: .Left = 6: .Top = 78: .Width = 204
End With
strCode = strCode & "Private Sub UserForm_Activate()" & vbLf
strCode = strCode & "'Récupération du hWnd du UserForm ufPipette" & vbLf
strCode = strCode & " hWndForm = FindWindow(""Thunder"" & IIf(Application.Version Like ""8*"", _" & vbLf
strCode = strCode & " ""X"", ""D"") & ""Frame"", Me.Caption)" & vbLf
strCode = strCode & "'La fenêtre du UserForm toujours au premier plan" & vbLf
strCode = strCode & "Dim lR As Long" & vbLf
strCode = strCode & " lR = SetTopMostWindow(hWndForm, True)" & vbLf
strCode = strCode & "End Sub" & vbLf
strCode = strCode & "Private Sub UserForm_Initialize()" & vbLf
strCode = strCode & " 'Identifiant unique"" & vbLf"
strCode = strCode & " AppId = GlobalAddAtom(""fred65200"")" & vbLf
strCode = strCode & " 'Raccourcis Alt + F pour copier, quitter" & vbLf
strCode = strCode & " lResult = RegisterHotKey(hwnd, AppId, MOD_ALT, vbKeyF)" & vbLf
strCode = strCode & " 'Passe la boucle des messages à la fonction WindowProc" & vbLf
strCode = strCode & " PrevWndProc = SetWindowLong(hwnd, GWL_WNDPROC, AddressOf WindowProc)" & vbLf
strCode = strCode & " 'temporisation" & vbLf
strCode = strCode & " Call Init(10)" & vbLf
strCode = strCode & "End Sub" & vbLf
strCode = strCode & "Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)" & vbLf
strCode = strCode & " Call Terminate" & vbLf
strCode = strCode & " lResult = SetWindowLong(hwnd, GWL_WNDPROC, PrevWndProc)" & vbLf
strCode = strCode & " 'suppression du raccourci" & vbLf
strCode = strCode & " lResult = UnregisterHotKey(hwnd, AppId)" & vbLf
strCode = strCode & "Call Copier" & vbLf
strCode = strCode & "End Sub" & vbLf
'Ajout de code
With uftemp.CodeModule
.InsertLines .CountOfLines + 1, strCode
End With
'affichage du useform
'VBA.UserForms.Add(ufTemp.Name).Show
' suppression du userform temporaire
'ThisWorkbook.VBProject.VBComponents.Remove ufTemp
'Application.VBE.CommandBars.FindControl(ID:=106).Execute ' --> pour Mac
Set uftemp = Nothing
End Sub |
