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 |
Partager