Positionner un formulaire sous un contrôle [Sources]

**Arkham46** · 14/04/2009, 09h32

Pour positionner un formulaire sous un contrôle :

Code A mettre dans un module :

Sélectionner tout - Visualiser dans une fenêtre à part

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
 
Option Compare Database
Option Explicit
 
'***************************************************************************************
'*                                       API                                           *
'***************************************************************************************
' Definition des variables non typees en long pour 32 bits ou longptr pour 64 bits
' Les elements des types doivent etre types obligatoirement
#If VBA7 Then
DefLngPtr A-Z
Const PtrNull As LongPtr = 0
#Else
DefLng A-Z
Const PtrNull As Long = 0
#End If
#If VBA7 Then
Private Declare PtrSafe Function SetWindowPos Lib "user32" (ByVal hwnd As LongPtr, ByVal hWndInsertAfter As LongPtr, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare PtrSafe Function GetWindowRect Lib "user32" (ByVal hwnd As LongPtr, lpRect As RectAPI) As Long
Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hdc As LongPtr) As Long
Private Declare PtrSafe Function GetDeviceCaps Lib "gdi32" (ByVal hdc As LongPtr, ByVal nIndex As Long) As Long
Private Declare PtrSafe Function ClientToScreen Lib "user32" (ByVal hwnd As LongPtr, lpPoint As POINTAPI) As Long
Private Declare PtrSafe Function SystemParametersInfo Lib "user32" Alias "SystemParametersInfoA" (ByVal uAction As Long, ByVal uParam As Long, ByRef lpvParam As RectAPI, ByVal fuWinIni As Long) As Long
#Else
Private Declare Function SetWindowPos Lib "USER32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowRect Lib "USER32" (ByVal hwnd As Long, lpRect As RectAPI) As Long
Private Declare Function GetDC Lib "USER32" (ByVal hwnd As Long) As Long
Private Declare Function ReleaseDC Lib "USER32" (ByVal hwnd As Long, ByVal Hdc As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal Hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function ClientToScreen Lib "USER32" (ByVal hwnd As Long, lpPoint As POINTAPI) As Long
Private Declare Function SystemParametersInfo Lib "USER32" _
                     Alias "SystemParametersInfoA" (ByVal uAction As Long, _
                     ByVal uParam As Long, ByRef lpvParam As RectAPI, _
                     ByVal fuWinIni As Long) As Long
#End If
'***************************************************************************************
'*                                       Types                                         *
'***************************************************************************************
' Type Point pour API
Private Type POINTAPI
    x As Long
    y As Long
End Type
Private Type RectAPI
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type
'***************************************************************************************
'*                                    Constantes                                       *
'***************************************************************************************
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOMOVE As Long = &H2
Private Const SWP_NOZORDER = &H4
Private Const SWP_SHOWWINDOW = &H40
Private Const LOGPIXELSY = 90
Private Const LOGPIXELSX = 88
Private Const SPI_GETWORKAREA = 48
 
'---------------------------------------------------------------------------------------
' Convertir les Twips en Pixels sur l'axe horizontal
'---------------------------------------------------------------------------------------
' pTwipsX : Valeur à convertir en Twips
' Renvoie la valeur convertie en Pixels
'---------------------------------------------------------------------------------------
 Public Function TwipsToPixelX(pTwipsX As Long) As Long
    Static Mult As Long
    Dim hdc
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSX)
        ReleaseDC 0, hdc
    End If
    TwipsToPixelX = CLng(pTwipsX / Mult)
End Function
 
'---------------------------------------------------------------------------------------
' Convertir les Twips en Pixels sur l'axe vertical
'---------------------------------------------------------------------------------------
' pTwipsY : Valeur à convertir en Twips
' Renvoie la valeur convertie en Pixels
'---------------------------------------------------------------------------------------
Public Function TwipsToPixelY(pTwipsY As Long) As Long
    Static Mult As Long
    Dim hdc
    If Mult = 0 Then
        hdc = GetDC(0)
        Mult = 1440 / GetDeviceCaps(hdc, LOGPIXELSY)
        ReleaseDC 0, hdc
    End If
    TwipsToPixelY = CLng(pTwipsY / Mult)
End Function
 
'---------------------------------------------------------------------------------------
' Positionne le formulaire pForm par rapport au contrôle pControl
'---------------------------------------------------------------------------------------
Public Sub PositionForm(pForm As Access.Form, pControl As Access.Control)
    Dim lParentForm As Access.Form
    Dim lPt As POINTAPI
    Dim lRect As RectAPI
    Dim lScreenRect As RectAPI
    Dim lScrWitdh As Single, lScrHeight As Single
    On Error GoTo Gestion_Erreurs
    ' Vérifie que le formulaire est en fenêtre indépendante
    If Not pForm.PopUp Then
        MsgBox "Le formulaire à positionner doit être en fenêtre indépendante" & _
                    vbCrLf & "(onglet Autre dans les propriétés du formulaire)", vbInformation
        SetWindowPos pForm.hwnd, 0, 0, 0, 0, 0, SWP_NOZORDER Or SWP_NOMOVE Or SWP_NOSIZE Or SWP_SHOWWINDOW
        Exit Sub
    End If
    ' Formulaire parent
    Set lParentForm = pControl.Parent
    ' Remonte jusqu'au formulaire si contrôle dans onglets
    If TypeOf lParentForm Is Page Then
        Do
            Err.Clear
            Set lParentForm = lParentForm.Parent
            If Err.Number <> 0 Then Err.Clear: Exit Do
        Loop
    End If
    ' Lit la taille du formulaire à positionner
    Call GetWindowRect(pForm.hwnd, lRect)
    lRect.Right = lRect.Right - lRect.Left + 1
    lRect.Bottom = lRect.Bottom - lRect.Top + 1
    ' Lit la taille de l'écran
    SystemParametersInfo SPI_GETWORKAREA, 0, lScreenRect, 0
    lScrWitdh = lScreenRect.Right - lScreenRect.Left + 1
    lScrHeight = lScreenRect.Bottom - lScreenRect.Top + 1
    ' Position du contrôle de positionnement
    lPt.x = TwipsToPixelX(pControl.Left + lParentForm.CurrentSectionLeft)
    lPt.y = TwipsToPixelY(pControl.Top + pControl.Height + lParentForm.CurrentSectionTop)
    ClientToScreen lParentForm.hwnd, lPt
    Set lParentForm = Nothing
    lRect.Left = lPt.x
    lRect.Top = lPt.y
    ' Doit tenir dans l'écran
    ' Si déborde à droite => décale le formulaire pour qu'il s'affiche entièrement
    If lRect.Left + lRect.Right > lScrWitdh Then
        lRect.Left = lScrWitdh - lRect.Right
    End If
    ' Si déborde en bas => affiche le formulaire au-dessus du contrôle
    If lRect.Top + lRect.Bottom > lScrHeight Then
        lRect.Top = lRect.Top - TwipsToPixelY(pControl.Height) - lRect.Bottom
    End If
    ' Repositionne le formulaire
    Call SetWindowPos(pForm.hwnd, 0, lRect.Left, lRect.Top, lRect.Right, lRect.Bottom, SWP_NOZORDER Or SWP_NOSIZE Or SWP_SHOWWINDOW)
    On Error GoTo 0
    Exit Sub
Gestion_Erreurs:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") dans la procédure PositionForm"
 
End Sub

Edit 04/06/2016 : module compatible Office 64bits

Exemple d'utilisation, sur click sur un bouton :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
 
Private Sub MonBouton_Click()
DoCmd.OpenForm "FormulaireAPositionner", , , , , acHidden
PositionForm Forms("FormulaireAPositionner"), Me.UneZoneDeTexte
End Sub

Pour un fonctionnement dans un formulaire continu, la zone de texte doit être située dans la même section que le bouton.
Le formulaire à positionner doit être en fenêtre indépendante (onglet Autres dans ses propriétés).

Le formulaire à positionner pForm se place sous le contrôle pControl.
Si le formulaire est trop grand, il est placé au dessus du contrôle.

**alassanediakite** · 18/04/2009, 23h44

Salut
J'ai tester, ça marche
Un grand merci à toi Arkham

**Blaise** · 23/08/2009, 16h18

Bonjour,

C'est magnifique

.
Personnellement je l'utilise à partir du gotfocus d'une zone de texte. Malheureusement le focus passe sur la popup et pour remettre le focus sur le "parent", j'ai quelque peu modifié le code de la procédure PositionForm comme suit :
(attention à la ligne Set lParentForm = Nothing déplacée)

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
Public Sub PositionForm(pForm As Access.Form, pControl As Access.Control)
' ... 
    lParentForm.SetFocus 'donne le focus au formulaire parent.
    Set lParentForm = Nothing ' cette ligne, située à l'origine plus haut, a été déplacée ici
    On Error GoTo 0
    Exit Sub
Gestion_Erreurs:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") dans la procédure PositionForm"
End Sub

Dans mon cas, le formulaire popup s'appelle "Frm_InfoBulle" et contient une étiquette lbl_infobulle.
Ce formulaire est chargé au lancement de l'application

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    DoCmd.OpenForm "Frm_InfoBulle", , , , , acHidden

Sa procédure d'activation est celle-ci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
 
Sub Infobulle(Vu As Boolean, Optional Ctl As Access.Control, Optional Texte As String)
    Forms("Frm_infobulle").Visible = Vu
    If Vu Then
        Forms("Frm_infobulle").lbl_infobulle.Caption = Texte
        PositionForm Forms("Frm_infobulle"), Ctl
    End If
End Sub

et son appel est, par exemple, celui-ci

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    Infobulle True, NomControle, Texte

et pour la cacher :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

    Infobulle False

.

C'est très très intéressant dans un formulaire continu, mais aussi dans d'autres circonstances.
Merci à vous, Blaise Cacramp.

**jehhej** · 27/01/2013, 14h12

Bonjour,

çà fonctionne impeccable, merci beaucoup. Je l'applique à un formulaire qui me sert de menu qui s'ouvre à chaque fois que je clique sur un controle "Action" d'un formulaire continu. Le formulaire-Menu contient des boutons "sélectionner", "modifier", "supprimer", etc.

Par contre, je souhaiterais que le formulaire s'affiche un peu plus à droite car actuellement le formulaire cache le contrôle "Action" d'autres enregistrements et il faut refermer à chaque fois le menu manuellement pour pouvoir cliquer sur "Action" du dessous.

Pouvez vous me dire quelles sont les lignes que je dois modifier pour décaler le formulaire vers la droite sans pose de problème au code s'il vous plait ?

**Arkham46** · 29/01/2013, 08h31

Envoyé par Jerome_Hej

Bonjour,

çà fonctionne impeccable, merci beaucoup. Je l'applique à un formulaire qui me sert de menu qui s'ouvre à chaque fois que je clique sur un controle "Action" d'un formulaire continu. Le formulaire-Menu contient des boutons "sélectionner", "modifier", "supprimer", etc.

Par contre, je souhaiterais que le formulaire s'affiche un peu plus à droite car actuellement le formulaire cache le contrôle "Action" d'autres enregistrements et il faut refermer à chaque fois le menu manuellement pour pouvoir cliquer sur "Action" du dessous.

Pouvez vous me dire quelles sont les lignes que je dois modifier pour décaler le formulaire vers la droite sans pose de problème au code s'il vous plait ?

Bonjour,

Vous pouvez ajouter la largeur du controle.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
lPt.x = TwipsToPixelX(pControl.Left + pControl.Width + lParentForm.CurrentSectionLeft)

**hyravas** · 30/10/2018, 20h59

Bonjour,
Ce code magnifique serait pile poil ce dont j’ai besoin pour afficher des info-bulles en dessous de certains champs de mon formulaire, mais il me donne « Error 13 Type mismatch » à la ligne 114:
Set lParentForm = pControl.Parent
J'ai repris le code tel quel, pForm correspond à mon formulaire popup et pControl est un champ texte situé sur une page d’un contrôle à onglets (même section que le bouton d'appel de routine).
Je travaille avec Access 2016. Avez-vous une idée de ce qui pourrait clocher ?
Merci !

**Arkham46** · 30/10/2018, 21h10

Bonjour,

Je n'ai pas 2016 pour tester.

Essayer de declarer en object lParentForm :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Dim lParentForm As Object

Au lieu de la ligne :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
 
Dim lParentForm As Access.Form

**hyravas** · 31/10/2018, 18h41

Bonjour,

Je confirme qu’en déclarant lParentForm comme Object, l’erreur 13 est réglée.
Par contre à la 3ème itération de la boucle If TypeOf lParentForm Is Page j’avais une erreur 2452 :

The expression you entered has an invalid reference to the Parent property

Je l’ai contournée avec On Error Resume Next avant la boucle, et tout marche impeccablement.

Merci beaucoup Arkham !

**theolivier** · 20/11/2020, 12h34

Bonjour,
Super code !
Le formulaire qui s'ouvre se positionne trop bas, comment faire pour qu'il se cal juste sous mon bouton parent ?
Merci d'avance.

Positionner un formulaire sous un contrôle [Sources]

Contribuez

Discussions similaires

Partager

Partager