PHV.FSM
XLDnaute Nouveau
Dans le cadre de développement d'application, il y a des objets que l'on souhaite positionner par rapport à une cellule mais qui sont positionnés par rapport à l'écran et dont les coordonnées sont souvent exprimées en pixel. Par exemple les UserForms ou le curseur de la souris. J'ai cru que la solution était simple et j'ai trouvé des solutions sur le net qui s'avéraient au final très spécifiques à une configuration particulière et qui ne donnaient pas un résultat universel.
Voici le code préalable nécessaire pour utiliser la procédure principale : GetGridPos.
Ainsi que le code suivant pour définir la taille du séparateur entre les panneaux :
Et enfin il faut inclure dans sa procédure d'initialisation le code suivant :
Si vous utilisé la fonction GetGridPos avec l'indexe de panneau actif numéro 1, les entêtes d'affichage sont prisent en compte par les fonctions PointsToScreenPixelsX et PointsToScreenPixelsY mais sinon ce n'est pas le cas, la largeur de ces entêtes est variable, et je n'ai pas trouver de moyen d' interroger leur dimension.
Du coup, il est plus simple de ne pas afficher les entêtes ... (jusqu'à trouver un code alternatif).
Sauf exception, si vous n'utilisé pas de panneau.
Il est tout d'abord nécessaire de pouvoir convertir les grandeurs physiques exprimées en point, en pixel et cette valeur que je nomme PxToPt (Single) doit être calculé au travers une procédure d'initialisation 'GetScreenData'; contrairement à ce que j'avais lu sur une solution ou il s'agissait d'une valeur constante car cela change en fonction de l'écran ou de la résolution.
Il existe la fonction suivante pour calculer la position sur l'écran d'une position ou grandeur sur la grille : Application.ActiveWindow.PointsToScreenPixelsX(x) ou PointsToScreenPixelsY(y)
x => Largeur ou abscisse
y => Hauteur ou ordonnée
Le problème c'est que cette fonction ne tient pas compte du zoom et que le calcul d'une largeur ou hauteur est approximatif dès que le zoom n'est pas à 100% dû au arrondis nécessaire pour passer d'une grandeur en point (valeur réelle) à une en pixel (valeur entière).
Voici la fonction pour calculer la distance entre deux rangées (Row ou Column) de la grille.
Ensuite l'utilisation de panneaux complique énormément la calcul de la position :
J'utilise la fonction PointsToScreenPixels{X ou Y} avec 0 en paramètre qui me donne la position du panneau ACTIF !
Il faut ajouter :
Classeur avec un exemple d'utilisation proposée :
Pour pouvoir exploiter ou tester la procédure 'GetGridPos' j'ai pris le cas de l'utilisation d'un menu contextuel pour simuler une ListBox à partir de cellule réagissant à la sélection ce qui est plus facile à visualiser et tester.
Classeur 'ScreenPosListBox' testé sous excel 2003 et 2016 mais qui devrait fonctionner sur toutes les versions depuis office 2003.
Remarque : j'utilise la propriété ID des cellules sur lesquelles je simule un Listbox. Cette propriété est initialisée à l'ouverture du classeur et persiste durant toute la session sauf si on efface la cellule.
C'est pour cela que j'ai ajouté une protection empêchant l'effacement de la propriété.
Voici le code préalable nécessaire pour utiliser la procédure principale : GetGridPos.
VB:
#If VBA7 Then
Private Declare PtrSafe Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare PtrSafe Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
#Else
Private Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
Private Declare Function apiCreateIC Lib "gdi32" Alias "CreateICA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long
Private Declare Function apiGetDeviceCaps Lib "gdi32" Alias "GetDeviceCaps" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function apiDeleteDC Lib "gdi32" Alias "DeleteDC" (ByVal hdc As Long) As Long
#End If
Private Const SM_CXSCREEN = 0
Private Const SM_CYSCREEN = 1
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
'*** Public data initiated with 'GetScreenData'
Public PxToPt As Single 'Parameter to convert a step in pixel in point
VB:
'Pane Separator Size in Point
#If VBA7 Then
Private Const SEP_PIXSIZE = 3 '=>Estimé entre {2.7 & 3.3}
#Else
Private Const SEP_PIXSIZE = 6 '=>Estimé entre {5.7 & 6.3}
#End If
Private SeparatorSize As Long
Sub GetGridData()
SeparatorSize = Round(SEP_PIXSIZE / PxToPt)
End Sub
VB:
' In user's module
Sub Init()
'(...)
Call GetScreenData: Call GetGridData
Application.ActiveWindow.DisplayHeadings = False
'(...)
End Sub
' In module 'ThisWorkbook' :
Private Sub Workbook_BeforeClose(Cancel As Boolean)
'(...)
Application.ActiveWindow.DisplayHeadings = True
'(...)
End SubDu coup, il est plus simple de ne pas afficher les entêtes ... (jusqu'à trouver un code alternatif).
Sauf exception, si vous n'utilisé pas de panneau.
Il est tout d'abord nécessaire de pouvoir convertir les grandeurs physiques exprimées en point, en pixel et cette valeur que je nomme PxToPt (Single) doit être calculé au travers une procédure d'initialisation 'GetScreenData'; contrairement à ce que j'avais lu sur une solution ou il s'agissait d'une valeur constante car cela change en fonction de l'écran ou de la résolution.
VB:
Sub GetScreenData()
Dim twipsPerPixelX As Long '?? ...
Dim lngIC As Long
Dim lngRet As Long
lngIC = apiCreateIC("DISPLAY", vbNullString, vbNullString, vbNullString)
If lngIC <> 0 Then
twipsPerPixelX = 1440 \ apiGetDeviceCaps(lngIC, LOGPIXELSX) 'Get the Screen X resolution
apiDeleteDC (lngIC) 'Release the information context.
Else 'Error : assume an average value.
lngRet = MsgBox("Error..invalid Display Device Context..Exiting", vbOKOnly)
Exit Sub
End If
ScreenWidth = GetSystemMetrics(SM_CXSCREEN)
ScreenHeight = GetSystemMetrics(SM_CYSCREEN)
PxToPt = (twipsPerPixelX / 20) 'Ratio convert twips to Pixel per Point
End SubIl existe la fonction suivante pour calculer la position sur l'écran d'une position ou grandeur sur la grille : Application.ActiveWindow.PointsToScreenPixelsX(x) ou PointsToScreenPixelsY(y)
x => Largeur ou abscisse
y => Hauteur ou ordonnée
Le problème c'est que cette fonction ne tient pas compte du zoom et que le calcul d'une largeur ou hauteur est approximatif dès que le zoom n'est pas à 100% dû au arrondis nécessaire pour passer d'une grandeur en point (valeur réelle) à une en pixel (valeur entière).
Voici la fonction pour calculer la distance entre deux rangées (Row ou Column) de la grille.
VB:
'(Use Running Constant PxToPt, ratio to convert point'size in pixel'size)
'Give pixel'size between two lines
Function GetGapSize(sht As Worksheet, startLine As Long, endLine As Long, isWidth As Boolean, zoomRatio As Single) As Long
Dim rgArea As Range, rgLine As Range
Dim lnPx As Single ' Long
Set rgArea = sht.Range(Cells(IIf(isWidth, 1, startLine), IIf(isWidth, startLine, 1)), _
Cells(IIf(isWidth, 1, startLine), IIf(isWidth, startLine, 1)))
If isWidth Then Set rgArea = sht.Range(sht.Cells(1, startLine), sht.Cells(1, endLine)) Else _
Set rgArea = sht.Range(sht.Cells(startLine, 1), sht.Cells(endLine, 1))
If zoomRatio = 1 Then
GetGapSize = IIf(isWidth, rgArea.Width, rgArea.Height) / PxToPt
Else
Set rgArea = IIf(isWidth, rgArea.Columns, rgArea.Rows)
For Each rgLine In rgArea
lnPx = IIf(isWidth, rgLine.Width, rgLine.Height)
If lnPx > 0 Then
lnPx = Round(lnPx * zoomRatio / PxToPt + 0.01) '0.01 fix round pb with xx.5
GetGapSize = GetGapSize + lnPx
End If
Next rgLine
End If
End FunctionJ'utilise la fonction PointsToScreenPixels{X ou Y} avec 0 en paramètre qui me donne la position du panneau ACTIF !
Il faut ajouter :
- Les rangées 'cachées' : ce sont les rangées situées entre la 1ère rangée et la rangée précédent la 1ère rangée visible dans le plan ACTIF.
- Les rangées sur le plan ou la cellule se situe de la 1ère rangée visible à la rangée précédente de la cellule.
- Les rangées visibles du plan actif si différent de celui de la cellule et si précédent celle-ci.
VB:
' Calcul the screen's coordinate of the top-left corner's cell
' cellTopLeft : grid's corner top-left point (CellTL)
' celPanIdx : Pane's index where CellTL is display
' Return : lXGrid, lYGrid position on screen (in Pixel)
Sub GetGridPos(ByRef lXGrid As Long, ByRef lYGrid As Long, cellTopLeft As Range, Optional celPanIdx As Integer = 1)
Dim sht As Worksheet 'Active Sheet in Active Workbook
Dim rgCrt As Range 'Current Area
Dim ratioZoom As Single 'Grid's ratio Zoom
'Pos Grid Var
Dim hideRows As Long, hideCols As Long 'Total of Hide Row and Column between Cells(1,1) and the beginning of the active's Area
Dim begRowAct As Long, endRowAct As Long, begColAct As Long, endColAct As Long 'Final active area's intervals
Dim begRowCel As Long, endRowCel As Long, begColCel As Long, endColCel As Long 'Final CellTL area's intervals
Dim rc1 As Long, rc2 As Long, cc1 As Long, cc2 As Long 'Row and Column interval of CellTL's Area between Start Area and Previous Cell's CellTL
Dim rz1 As Long, rz2 As Long, cz1 As Long, cz2 As Long 'Row and Column interval of Area(1) : (rz1,rz2) and (cz1,cz2)
Dim isOK As Boolean, isPanVert2 As Boolean, isPanHor2 As Boolean
Dim typPan As Integer 'Total Pane => 0 : 1, 1 : 2 Verticals, 2 : 2 Horizontals, 3 : 4
Dim actPanIdx As Integer 'Index of actif pane
Set sht = ActiveWorkbook.ActiveSheet
With Application
With .ActiveWindow
lXGrid = .PointsToScreenPixelsX(0)
lYGrid = .PointsToScreenPixelsY(0)
If (celPanIdx > 1) And Not (.FreezePanes) Then
.SplitRow = .SplitRow: .SplitColumn = .SplitColumn 'Force separators position (between 2 range)
isOK = True
End If
typPan = -(.SplitColumn > 0) - 2 * (.SplitRow > 0)
isPanVert2 = ((celPanIdx - 1) And typPan) And 1 'True if Cell Pane is on right
isPanHor2 = (celPanIdx - 1) And (typPan - 1) 'True if Cell Pane is on bottom
If isOK Then 'Add pane's Sep width if panes are free
If isPanVert2 Then lXGrid = lXGrid + SeparatorSize
If isPanHor2 Then lYGrid = lYGrid + SeparatorSize
End If
ratioZoom = .Zoom / 100 'Theoretical zoom ratio
Set rgCrt = .ActivePane.VisibleRange
hideRows = rgCrt.Row - 1: hideCols = rgCrt.Column - 1 'Total hide line
actPanIdx = .ActivePane.Index
Set rgCrt = .Panes(celPanIdx).VisibleRange 'Get CellTL Intervals (rc1 to rc2, cc1 to cc2)
rc1 = rgCrt.Row: rc2 = cellTopLeft.Row - 1: If rc1 > rc2 Then rc1 = 0
cc1 = rgCrt.Column: cc2 = cellTopLeft.Column - 1: If cc1 > cc2 Then cc1 = 0
Set rgCrt = .Panes(1).VisibleRange 'Get Pane(1) Intervals (rz1 to rz2, cz1 to cz2)
If isPanHor2 Then
rz1 = rgCrt.Row: rz2 = rz1 + rgCrt.Rows.Count - 1
End If
If isPanVert2 Then
cz1 = rgCrt.Column: cz2 = cz1 + rgCrt.Columns.Count - 1
End If
If celPanIdx = actPanIdx Then 'if CellTL is on active pane
begRowAct = rc1: begColAct = cc1: endRowAct = rc2: endColAct = cc2
begRowCel = rz1: begColCel = cz1: endRowCel = rz2: endColCel = cz2
Else
If ((celPanIdx + 1) Xor (actPanIdx + 1)) Or typPan = 2 Then
begRowCel = rc1: endRowCel = rc2: begRowAct = rz1: endRowAct = rz2
Else
begRowCel = rz1: endRowCel = rz2: begRowAct = rc1: endRowAct = rc2
End If
If (typPan And 1) And ((celPanIdx Xor actPanIdx) And 1) Then
begColCel = cc1: endColCel = cc2: begColAct = cz1: endColAct = cz2
Else
begColCel = cz1: endColCel = cz2: begColAct = cc1: endColAct = cc2
End If
End If
'Add the CellTL offset to coordinates
lXGrid = lXGrid + CalCelOff(sht, True, ratioZoom, hideCols, begColCel, endColCel, begColAct, endColAct)
lYGrid = lYGrid + CalCelOff(sht, False, ratioZoom, hideRows, begRowCel, endRowCel, begRowAct, endRowAct)
End With
End With
End Sub
'Calcul CellTL offset : interval's sum of the 'Hide Area'(ha), the 'CellTL Area' and the active Area
'st : the Active Sheet
'iW : true if is a width interval else is a height interval
'zR : ratio zoom of the active sheet
'ha : Total of Hide line(s) between Cells(1,1) and the beginning of the active Area
'c1, c2 : interval(c1,c2) of the 'CellTL' Area
'a1, a2 : interval(a1,a2) of the active Area
Private Function CalCelOff(st As Worksheet, iW As Boolean, zR As Single, ha As Long, c1 As Long, c2 As Long, a1 As Long, a2 As Long) As Long
Dim r As Long
If ha = 0 Then
If a1 > 0 Then
If c1 > 0 Then CalCelOff = CalCelOff2(st, iW, zR, c1, c2, a1, a2) Else CalCelOff = GetGapSize(st, a1, a2, iW, zR)
Else
If c1 > 0 Then CalCelOff = GetGapSize(st, c1, c2, iW, zR)
End If
Else
If a1 > 0 Then
If ha = a1 - 1 Then a1 = 1 Else r = GetGapSize(st, 1, ha, iW, zR)
If c1 > 0 Then CalCelOff = r + CalCelOff2(st, iW, zR, a1, a2, c1, c2) Else CalCelOff = r + GetGapSize(st, a1, a2, iW, zR)
Else
If c1 > 0 Then CalCelOff = CalCelOff2(st, iW, zR, 1, ha, c1, c2) Else CalCelOff = GetGapSize(st, 1, ha, iW, zR)
End If
End If
End Function
'Calcul 2 interval's sum
'st : the Active Sheet
'iW : true if is a width interval else is a height interval
'zR : ratio zoom of the active sheet
'(a,b) and (c,d) : intervals
Private Function CalCelOff2(st As Worksheet, iW As Boolean, zR As Single, a As Long, b As Long, c As Long, d As Long) As Long
Dim r As Long, e As Long, f As Long
e = c
If c < a Then
f = d: c = a: d = b: a = e: b = f: e = c
End If
If c > b Then
If b = c - 1 Then CalCelOff2 = GetGapSize(st, a, d, iW, zR) Else CalCelOff2 = GetGapSize(st, a, b, iW, zR) + GetGapSize(st, c, d, iW, zR)
Else
If c > a Then r = GetGapSize(st, a, c - 1, iW, zR)
If b > d Then
f = d: r = r + GetGapSize(st, d + 1, b, iW, zR)
Else
f = b: If d > b Then r = r + GetGapSize(st, b + 1, d, iW, zR)
End If
CalCelOff2 = r + 2 * GetGapSize(st, e, f, iW, zR)
End If
End FunctionClasseur avec un exemple d'utilisation proposée :
Pour pouvoir exploiter ou tester la procédure 'GetGridPos' j'ai pris le cas de l'utilisation d'un menu contextuel pour simuler une ListBox à partir de cellule réagissant à la sélection ce qui est plus facile à visualiser et tester.
Classeur 'ScreenPosListBox' testé sous excel 2003 et 2016 mais qui devrait fonctionner sur toutes les versions depuis office 2003.
Remarque : j'utilise la propriété ID des cellules sur lesquelles je simule un Listbox. Cette propriété est initialisée à l'ouverture du classeur et persiste durant toute la session sauf si on efface la cellule.
C'est pour cela que j'ai ajouté une protection empêchant l'effacement de la propriété.
Dernière édition:
