P.J. :
La fonction permettant d'obtenir la position écran à partir du coin Haut-Gauche d'une cellule est GetScreenGridPos et GetScreenGridPosV11 pour la version Excel 2003.
Remarque : pour plus de détails sur la version XLS 2003 voir le sujet Calculer la position sur l'écran d'une position sur la grille (XL 2003)
Les modules 'exemples' permettant de tester les fonctions ci-dessus
Une fonction PosResizeWindow permet de maîtriser l'affichage du UserForm, de changer la position et la taille sans aucune limite (voir la fonction 'Retailler en Mini')
Retirer la compatibilité avec Excel 2003
par
Il faut retirer, dans la fonction 'GetScreenGridPos', la partie en commentaire 'COMP2003'
La fonction 'GetGapSize' n'a pas forcément d'utilité sauf cas particulier et peut être retiré aussi
- GetScreenPosDemo2.xlsm : la démo
- GetScreenPosDemo2.xls : la conversion pour Excel 2003
La fonction permettant de convertir une position de la grille en position écran et toutes les fonctions associées sont contenues dans le module 'Lib' et les fonctions assurant la compatibilité avec Excel 2003 dans le module 'LibV11'.
Avec ce problème, c'est l'occasion de montrer comment assurer la compatibilité avec toutes les versions depuis 2003 avec la constante de précompilation classique VBA7 mais qui ne répond pas au problème du passage de la version 2003 à 2007. Dans ce cas il faut utiliser du simple code :
VB:
XLS2003 = IIf(Val(Application.Version) < 12, True, False)La fonction permettant d'obtenir la position écran à partir du coin Haut-Gauche d'une cellule est GetScreenGridPos et GetScreenGridPosV11 pour la version Excel 2003.
Remarque : pour plus de détails sur la version XLS 2003 voir le sujet Calculer la position sur l'écran d'une position sur la grille (XL 2003)
Les fonctions pane.PointsToScreenPixelsX et pane.PointsToScreenPixelsY d'Excel assure déjà plutôt bien cette fonction (disponible depuis la version Excel 2007) mais comporte une imprécision variant de 1 (zoom à 100%) à 4 pixels(zoom à 400%) qui est corrigé par cette fonction reprenant le principe de l'algorithme développé par Pijaku en éliminant les 2 à 3% de cas d'echec de sa fonction et en améliorant la performance.
Source : voir le sujet Déterminer les coordonnées en pixels, par rapport à l'écran, du coin supérieur gauche d'une cellule Excel
Ce que j'ai corrigé ce sont les cas ou la position déterminée au départ est située en dehors de la grille et qui concerne les cellules du pourtour de la grille. Pour retrouver la grille je me déplace en diagonale en direction de la grille plutôt que de façon rectiligne. Une fois la grille trouvée je cherche le coin de la cellule en me déplaçant de façon rectiligne.
Source : voir le sujet Déterminer les coordonnées en pixels, par rapport à l'écran, du coin supérieur gauche d'une cellule Excel
Ce que j'ai corrigé ce sont les cas ou la position déterminée au départ est située en dehors de la grille et qui concerne les cellules du pourtour de la grille. Pour retrouver la grille je me déplace en diagonale en direction de la grille plutôt que de façon rectiligne. Une fois la grille trouvée je cherche le coin de la cellule en me déplaçant de façon rectiligne.
VB:
' Init :
Public Type ScreenPos
Px As Long
Py As Long
End Type
'Function :
Public Function GetScreenGridPos(ByVal noPane As Integer, ByVal cellTopLeft As Range) As ScreenPos
Dim cel As Range, x As Long, y As Long, crtPane As Pane
Dim wayHor As Integer, wayVert As Integer, state As Byte, totIt As Byte
Set crtPane = ActiveWindow.Panes(noPane)
With crtPane
'Repérer la 1ère ligne et la 1ère colonne du volet
wayHor = IIf(cellTopLeft.Column = .ScrollColumn, 1, -1) 'Sens Hor
wayVert = IIf(cellTopLeft.row = .ScrollRow, 1, -1) 'Sens Vert
x = .PointsToScreenPixelsX(cellTopLeft.Left)
y = .PointsToScreenPixelsY(cellTopLeft.Top)
Do
Set cel = ActiveWindow.RangeFromPoint(x, y)
If cel Is Nothing Then
If (state And 2) Then state = state + 2
x = x + wayHor: y = y + wayVert
Else
If state < 3 Then
If cel.Left < cellTopLeft.Left Then
state = IIf(state = 2, 4, 1)
x = x + 1
Else
Select Case state
Case 0: wayHor = 1: wayVert = 0: state = 2
Case 1: state = 4
Case 2: x = x - 1
End Select
End If
End If
If state > 3 Then
If cel.Top < cellTopLeft.Top Then
state = IIf(state = 6, 8, 5)
y = y + 1
Else
Select Case state
Case 4: wayHor = 0: wayVert = 1: state = 6
Case 5: state = 8
Case 6: y = y - 1
End Select
End If
End If
End If
totIt = totIt + 1: If totIt = 20 Then state = 9
Loop Until state > 7
End With
'State = 9 : retour=(0,0)
GetScreenGridPos.Px = IIf(state = 8, x, 0)
GetScreenGridPos.Py = IIf(state = 8, y, 0)
End FunctionLe deuxième élément important à calculer est le coefficient permettant de passer d'une grandeur en pixel vers une grandeur en point :
J'ai créer une variable globale 'PxToPt' que je calcule au moment de l'initialisation.
Il existe plusieurs façon de calculer ce coefficient, dont une qui utilise des fonctions systèmes et permet aussi de connaître la résolution de l'écran.
Cf la fonction 'GetScreenData' : voir le sujet Calculer la position sur l'écran d'une position sur la grille (XL 2003)
Sinon il existe ce calcul très simple que j'ai testé avec toute les valeurs entières de zoom entre 10 et 400 et fonctionne très bien :
Fonction révisée après intervention de Dudu2 avec un arrondi à 2 chiffres après la virgule.J'ai créer une variable globale 'PxToPt' que je calcule au moment de l'initialisation.
Il existe plusieurs façon de calculer ce coefficient, dont une qui utilise des fonctions systèmes et permet aussi de connaître la résolution de l'écran.
Cf la fonction 'GetScreenData' : voir le sujet Calculer la position sur l'écran d'une position sur la grille (XL 2003)
Sinon il existe ce calcul très simple que j'ai testé avec toute les valeurs entières de zoom entre 10 et 400 et fonctionne très bien :
VB:
' Init : var globale
Public PxToPt#
' Func
Function SetPxToPt() As Double
Const K1 As Long = 15
With ActiveWindow
PxToPt = Round(K1 * .Zoom / (.Panes(1).PointsToScreenPixelsX(K1 * 100) - .Panes(1).PointsToScreenPixelsX(0)), 2)
End With
End FunctionCette macro ne peut être utilisée sous Excel 2003 car pane.PointsToScreenPixelsXouY n'existait pas et il y a donc la macro 'SetPxToPtV11' qui détermine le taux par tatonnement. Elle cherche la plus petite hauteur d'une ligne (1 pixel) et interroge excel pour savoir quel est cette hauteur en point. Dans le module 'LibV11'
Il existe dans le module 'Tools' une autre façon générique d'obtenir ce coefficient fournie par patricktoulon :
VB:
Function PointToPixel() As Double
Static SavePointToPixel As Double
If SavePointToPixel = 0 Then
SavePointToPixel = CreateObject("WScript.Shell").RegRead("HKEY_CURRENT_USER\Control Panel\Desktop\WindowMetrics\AppliedDPI") / Application.InchesToPoints(1)
End If
PointToPixel = SavePointToPixel
' Debug.Print "PxToPt = " & 1 / PointToPixel
End FunctionLes modules 'exemples' permettant de tester les fonctions ci-dessus
Le module 'Ex1'
Il met à disposition un menu contextuel qui permet de changer le nombre de volet, le zoom, de changer d'algo pour tester GetScreenGridPos et GetScreenGridPosV11 ...
Le module 'Ex2'
Il est possible d'afficher le Userform1 depuis le menu contextuel mais dans certaines versions Excel (ou windows), l'affichage du menu contextuel déborde un peu par rapport à la position d'affichage.
La fonction 'SwapUFwinStyle' utilisant des fonctions système, permet de modifier l'apparence du Userform en le transformant en simple rectangle, est une solution au problème ci-dessus. Accessible depuis le menu avec le bouton 'Basculer en Style Simple'.
Remarque : SetWindowLong doit être associée à la fonction SetWindowPos cela fait parti des modifications effectuée sur cette version.La fonction 'SwapUFwinStyle' utilisant des fonctions système, permet de modifier l'apparence du Userform en le transformant en simple rectangle, est une solution au problème ci-dessus. Accessible depuis le menu avec le bouton 'Basculer en Style Simple'.
Une fonction PosResizeWindow permet de maîtriser l'affichage du UserForm, de changer la position et la taille sans aucune limite (voir la fonction 'Retailler en Mini')
Retirer la compatibilité avec Excel 2003
- Il faut supprimer le module 'LibV11'
- Dans le module 'Lib' :
Il faut modifier la macro 'InitLib' en remplaçant
VB:
Call InitLibV11
VB:
SetPxToPtLa fonction 'GetGapSize' n'a pas forcément d'utilité sauf cas particulier et peut être retiré aussi
- Auteur
- Ludovic FERRON
- Version
- 1.1
