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
| Option Explicit
Private Enum DWMWINDOWATTRIBUTE
DWMWA_NCRENDERING_ENABLED = 1
DWMWA_NCRENDERING_POLICY
DWMWA_TRANSITIONS_FORCEDISABLED
DWMWA_ALLOW_NCPAINT
DWMWA_CAPTION_BUTTON_BOUNDS
DWMWA_NONCLIENT_RTL_LAYOUT
DWMWA_FORCE_ICONIC_REPRESENTATION
DWMWA_FLIP3D_POLICY
DWMWA_EXTENDED_FRAME_BOUNDS
DWMWA_LAST
End Enum
Private Enum BOOL
FALSE_
TRUE_
End Enum
'#If False Then
' Dim FALSE_, TRUE_
'#End If
Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Type myRECT
Left As Double
Top As Double
Right As Double
Bottom As Double
End Type
Private Declare Function DwmGetWindowAttribute Lib "dwmapi.dll" (ByVal hwnd As Long, ByVal dwAttribute As Long, ByRef pvAttribute As Any, ByVal cbAttribute As Long) As Long
Private Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef pfEnabled As BOOL) As Long
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Col As Long, Lig As Long
Private Const X_PAR_DEFAUT As Long = 0
Private Const Y_PAR_DEFAUT As Long = 0
Private Const CONV_PPX As Long = 72
Public Function fPosCel(RngTarget As Range, BoolRetour As Boolean) As myRECT
Dim DblPpx As Double
Dim LngPane As Long, LngNbPanes As Long
Dim BoolScreenUp As Boolean
'TESTS-----------------------------------------
If Application.WindowState = xlMinimized Or fTestWindow = False Then
fPosCel.Top = Y_PAR_DEFAUT
fPosCel.Left = X_PAR_DEFAUT
Exit Function
End If
If Application.ScreenUpdating = False Then
Application.ScreenUpdating = True
BoolScreenUp = True
End If
'/TESTS-----------------------------------------
BoolRetour = True
DblPpx = fPpx(CONV_PPX)
LngNbPanes = ActiveWindow.Panes.Count
For LngPane = 1 To LngNbPanes
With ActiveWindow.Panes(LngPane)
If Not Intersect(RngTarget, .VisibleRange) Is Nothing Then
fPosCel.Left = .PointsToScreenPixelsX(RngTarget.Left) / DblPpx
fPosCel.Top = .PointsToScreenPixelsY(RngTarget.Top) / DblPpx
Exit For
Else
fPosCel.Top = Y_PAR_DEFAUT
fPosCel.Left = X_PAR_DEFAUT
End If
End With
Next
If BoolScreenUp Then Application.ScreenUpdating = False
End Function
Public Function fMarges(Usf_Caption As String, Usf_Left As Double, Usf_Top As Double) As RECT
Dim DblPpx As Double
Dim LngResult As Long, LngHwnd As Long
Dim BoolFreeze As Boolean
DblPpx = fPpx(CONV_PPX)
If ActiveWindow.FreezePanes = True Then BoolFreeze = True: Call sLibere(False)
LngHwnd = fHwndFenetre(Usf_Caption)
If LngHwnd = -1 Then
'retourne 0 si hWnd pas trouvé
fMarges.Left = 0
fMarges.Top = 0
GoTo Defreeze
End If
LngResult = fCalculeMarges(fMarges, LngHwnd)
If LngResult = -1 Then
'retourne 0 si XP
fMarges.Left = 0
fMarges.Top = 0
GoTo Defreeze
End If
If fIsAeroActivated Then
fMarges.Left = Usf_Left - (fMarges.Left / DblPpx)
fMarges.Top = Usf_Top - (fMarges.Top / DblPpx)
Else
'retourne 0 si aero désactivé
fMarges.Left = 0
fMarges.Top = 0
End If
Defreeze:
If BoolFreeze Then Call sRefige(True)
End Function
Private Function fTestWindow() As Boolean
Dim WinDo As Window, BoolTestWindow As Boolean
For Each WinDo In Application.Windows
If WinDo.Visible = True Then
BoolTestWindow = True
Exit For
End If
Next WinDo
fTestWindow = BoolTestWindow
End Function
Private Function fPpx(Nb As Long) As Double
With CreateObject("WScript.Shell")
fPpx = .RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Nb
End With
End Function
Private Function fHwndFenetre(Usf_Caption As String) As Long
On Error Resume Next
fHwndFenetre = FindWindow(vbNullString, Usf_Caption)
If Err <> 0 Then
Err.Clear
fHwndFenetre = -1
End If
End Function
Private Function fCalculeMarges(M As RECT, LngHwnd As Long) As Long
On Error Resume Next
fCalculeMarges = DwmGetWindowAttribute(LngHwnd, DWMWA_EXTENDED_FRAME_BOUNDS, M, LenB(M))
If Err <> 0 Then
Err.Clear
fCalculeMarges = -1
End If
End Function
Private Function fIsAeroActivated() As Boolean
Dim BOOLAero As BOOL
Const S_OK = 0&
On Error Resume Next
fIsAeroActivated = (DwmIsCompositionEnabled(BOOLAero) = S_OK And BOOLAero = TRUE_)
If Err <> 0 Then
Err.Clear
fIsAeroActivated = False
End If
End Function
Private Sub sLibere(Comment As Boolean)
With ActiveWindow
Col = .SplitColumn
Lig = .SplitRow
.FreezePanes = Comment
End With
End Sub
Private Sub sRefige(Comment As Boolean)
With ActiveWindow
.SplitColumn = Col
.SplitRow = Lig
.FreezePanes = Comment
End With
End Sub |
re
Envoyé par unparia
Partager