Position de formulaire

Version imprimable

20/06/2024, 19h06
deedolith

Position de formulaire

Bonjour,

Dans un environnement multi-écran, j'experimente des difficultés à positionner un formulaire dans le coin haut/gauche de la feuille active.
Après recherche, il s'avère que c'est lié au facteur d'échelle de windows.

Comment contourner ce problème ?
20/06/2024, 20h54
Jean-Philippe André

Salut,

quel est ton code actuel ?

Est-ce que tes Application.Top ou .Left ne suffisent pas à arriver à tes fins ?
20/06/2024, 23h08
deedolith

Ben non,

Application.Top et Application.Left correspondent au coin supérieur gauche de la fenêtre Excel, le formulaire s'affiche sur le ruban (et j'utilise ce dernier).
C'est la première cellule visible qui m'intéresse.

Je poste un extrait de code dès que possible.

J'ai le code suivant

Code:

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
Sub Test()
    Dim Rect As Rect
     Rect = GetCellRect(ActiveWindow.ActivePane.VisibleRange.Cells(1))
 
    Dim Frm as Form1
    Set Frm = New Form1
    Frm.Top = Rect.Top
    Frm.Left = Rect.Left
End Sub
 
'// Source: https://github.com/nervgh/vba/blob/master/GetRectForExcel2007Plus/test.xlsm_VBProject/mod_GetRectForExcel2007Plus.bas
' ----------------------------------------
' Returns the cell coordinates in points relative to the screen
'
' @param {Object} Target the cell
' @return {Rect} the cell coordinates
' ----------------------------------------
Public Function GetCellRect(ByVal Target As Excel.Range) As Rect
    Const FunctionName As String = "GetCellRect"
    Dim ErrorLogger As ErrorLogger
    Set ErrorLogger = Factory.CreateErrorLogger(ModuleName, FunctionName)
 
    With ActiveWindow
        Set Target = Target.MergeArea
 
        Dim Index As Integer
        For Index = 1 To .Panes.Count
            If Not Intersect(Target, .Panes(Index).VisibleRange) Is Nothing Then
                Dim Rect As Rect
                With .Panes(Index)
                    Rect.Left = PixelsToPoints(.PointsToScreenPixelsX(Target.Left))
                    Rect.Top = PixelsToPoints(.PointsToScreenPixelsY(Target.Top))
                End With
                Rect.Right = Target.Width * .Zoom / 100 + Rect.Left
                Rect.Bottom = Target.Height * .Zoom / 100 + Rect.Top
                GetCellRect = Rect
                Exit Function
            End If
        Next
    End With
End Function

Avec un facteur d'échelle de 100%, pas de problème.
Avec un facteur autre, le formulaire est mal positionné.

Bonjour,

j'ai cette approximation qui traine dans mes tiroirs

Code:

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
Option Explicit
Declare PtrSafe Function GetDC& Lib "user32.dll" (ByVal hwnd&)
Declare PtrSafe Function GetDeviceCaps& Lib "gdi32" (ByVal hDC&, ByVal nIndex&)
 
Sub position_usf(usf, cel)
    ' 1 inch = 72 points for usually 96 or 120 dpi
    Dim x As Double, y As Double
    x = GetDeviceCaps(GetDC(0), 88) / 72
    y = GetDeviceCaps(GetDC(0), 90) / 72
    With usf
        .StartUpPosition = 0
        .Left = (ActiveWindow.PointsToScreenPixelsX(cel.Left * x) * 1 / x)
        .Top = (ActiveWindow.PointsToScreenPixelsY(cel.Top * y) * 1 / y)
    End With
    ActiveWindow.ScrollRow = cel.Row
    ActiveWindow.ScrollColumn = cel.Column
End Sub

A utiliser :

Code:

1
2
3
Private Sub UserForm_Activate()
    position_usf Me, Cells(1, 1)
End Sub

21/06/2024, 11h11
deedolith

Ca fait le café.

Merci.