[XL-2007] affichage du menupopup [Résolu]

[patricktoulon]

bonjour a tous

j'ai fait des menus contextuels de remplacement dans un classeur

ce que je voudrais c'est qu'il s'affiche dans un endroit particulier de la feuille


quelqu'un a une idée

merci d'avance

[Daniel.C]

Bonjour Patrick,

Peut-être la méthode "ShowPopup".

[patricktoulon]

bonjour daniel


oui je sait

Code :

mabarre.showpopup(x,y)

mais c'est le x et le y que je voudrais déterminer

par exemple je voudrais que ma barre apparaisse a la cellule F5

je fais donc

Code :

mabarre.showpopup([f5].left,[f5].top)

mais comme ça commence en dessous de la barre de formule ce qui donne une différence de l'épaisseur du ruban

une idée

au plaisir

[Daniel.C]

J'au du mal à te suivre, je suis loin d'être expert en commandbars (en autres). Est-ce que la connaissance de la cellule en haut et à gauche de la fenêtre peut aider ?

Code :

ActiveWindow.VisibleRange(1, 1).Address

[ctac_]

Bonjour,

Les x et y de showpopup sont des coordonnées de l'écran et les top et left sont des coordonnées relatives a la fenêtre Excel.
Je pense que tu n'échapperas pas aux API.

Bon courage !

ctac

[patricktoulon]

bonjour danielc et ctac

pour ctac:

oui je suis d'accord avec toi mais c'est la mise en oeuvre dont je n'est aucune idée pourtant j'ai l'habitude de manipuler les apis

je continu a chercher

au plaisir

[Qwazerty]

Salut

Peux tu placer au minima un code démo au mieux un fichier démo, j'ai la flemme d'en construire un pour faire des essais

++
Qwaz

[patricktoulon]

bonjour qwazerty


bon j'ai bricoler quelque chose d'un peu barbare mais bon c'est fonctionnel

a l'open du classeur


je lance la fonction :hauteur_ruban2

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
 
Type POINTAPI
      X As Long
      Y As Long
End Type
Dim point As POINTAPI
 
Dim obj As Object
Dim ligne As Long
Dim colonne As Long
Function hauteur_ruban2() As String
X = 200
Y = 0
Do
 Y = Y + 2
     Set obj = ActiveWindow.RangeFromPoint(200, Y) 'trouve l'object aucoordonnées (x,y)
If TypeName(obj) = "Range" Then
If obj.Row = 5 Then
ligne = obj.Row
End If
End If
DoEvents
Loop Until ligne = 5
Sheets("enveloppe").[h3] = Y
Do
X = X + 2
Set obj = ActiveWindow.RangeFromPoint(X, Y) 'trouve l'object aucoordonnées (x,y)
If TypeName(obj) = "Range" Then
If obj.Column = 7 Then
colonne = obj.Column
End If
End If
Loop Until colonne = 7
Sheets("enveloppe").[i3] = X
End Function

donc en h3 et i3 j'ai le left et le top ou doit s'afficher le menu

ensuite le menu popup

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
42
43
44
45
46
47
48
49
 
Sub MENUdestinataire()
    fois = True
 
    Dim Barre As CommandBar
    On Error GoTo suite
    CommandBars("menudestinataire").Delete
suite:
  On Error GoTo 0
  Cancel = True
  Set Barre = CommandBars.Add("menudestinataire", msoBarPopup, False, True)
 
  Set popup1 = Barre.Controls.Add(msoControlPopup, , , , True)
    With popup1
    .Caption = "Supprimer un destinataire"
    End With
 
 
  Set popup2 = Barre.Controls.Add(msoControlPopup, , , , True)
    With popup2
    .Caption = "choisir un destinataire"
    End With
 
 
 
    derlig = Sheets("liste de nom").Range("a65530").End(xlUp).Row
 
    For e = 2 To derlig
 
 
        With popup2.Controls.Add(msoControlButton, , , , True)
            .Caption = Sheets("liste de nom").Cells(e, 1)
            .FaceId = 326
            .Tag = Sheets("liste de nom").Cells(e, 1) & ":" & Sheets("liste de nom").Cells(e, 2) _
                      & ":" & Sheets("liste de nom").Cells(e, 3) & ":" & Sheets("liste de nom").Cells(e, 4) _
                      & ":" & Sheets("liste de nom").Cells(e, 5) & ":" & Sheets("liste de nom").Cells(e, 6)
            .OnAction = "dest"
        End With
 
 With popup1.Controls.Add(msoControlButton, , , , True)
            .Caption = Sheets("liste de nom").Cells(e, 1)
            .FaceId = 326
            .Tag = e
            .OnAction = "suppresion_destinataire"
 
        End With
Next
CommandBars("menudestinataire").ShowPopup [i3], [h3]
End Sub

comme j'ai plusieurs menu je donne les meme coordonnées a tous et il s'affichent au meme endroit

cela dit c'est un peu babare comme code j'en conviens

comme tu peux le constater j'ai utilisé ton astuce sur le transport de variables par le tag des bouton


a tu une idée plus propre?
au plaisir

[patricktoulon]

bonjour a tous

et voila maintenant j'ai mal a la tete


voila la fonction qui donne la hauteur du rauban par les apis

j'avais completement oublié ce petit code que j'utilisait au depart pour l'effet mouse over sur les lignes d'un sheets


je l'ai un peu remanier et voila

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
42
43
44
 
Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Declare Function GetSystemMetrics Lib "user32" (ByVal nIndex As Long) As Long
 
 
Type POINT_
      X As Long
      Y As Long
End Type
Type RECT
      Left As Long
     Top As Long
     Right As Long
     Bottom As Long
End Type
 
Const decalage = 6 'l'eppaisseur des bords des fenetres
Dim coord As RECT
Dim nomclasse As String * 200
 
Function hauteur_ruban() As Long
'recherche de la fenetre de la page active
     pointeur = FindWindow("XLMAIN", vbNullString) 'on pointe le han,dle de l'application
     pointeur = GetWindow(pointeur, 5)
     Do
     'on boucle jusqu'a revenir sur le handle de l'application
     GetClassName pointeur, nomclasse, 250
     If LCase(Left(nomclasse, 6)) = "xldesk" Then Exit Do
     pointeur = GetWindow(pointeur, 2)
     Loop
'recherche de la position et taille de la fenetre le pointeur pointe maintenant sur la grille excel  uniquement
    Call GetWindowRect(pointeur, coord)
     'GetSystemMetrics(1)donne la hauteur de la resolution de l'ecran
     'coord.Bottom - coord.Top donne le height du rectangle que represente la grille excel
     'la soustraction des deux + le decalage (epaisseur des bords de fenetre) donne la hauteur du ruban ou tout ce qui n'est pas la grille
     hauteur_ruban = GetSystemMetrics(1) - (coord.Bottom - coord.Top) - decalage
 
End Function
Sub test_hauteur_ruban()
MsgBox hauteur_ruban
End Sub

la seule chose il faut que l'application soit maximisée sinon sa donne le top de

la grille excel par rapport a l'ecran

y a t-il quelque chose de plus propre que ca ??

toute suggestion est la bien venue


au plaisir

[Qwazerty]

Salut
Je n'ai pas étudié le code que tu proposes faute de temps, mais pourquoi ne tiens tu pas compte de la position de la fenêtre sur l'écran avec Application.Left/Top et Windows.Left/Top.

[Edit]
J'ai regardé un peu plus ton code, voila quelques modifications, le résultat est encore imparfait il faut gratter encore

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
Option Explicit
 
Sub MENUdestinataire()
Dim Barre As CommandBar
Dim E As Integer, iCol As Integer
Dim PopUp1 As CommandBarControl, PopUp2 As CommandBarControl
Dim strTag As String
Dim sngTop As Integer, sngLeft As Integer
 
 
 
    'fois = True '?
 
    On Error Resume Next 'GoTo suite
    CommandBars("menudestinataire").Delete
    'suite:
    On Error GoTo 0
 
    'Cancel = True '?
    Set Barre = CommandBars.Add("menudestinataire", msoBarPopup, False, True)
 
    Set PopUp1 = Barre.Controls.Add(msoControlPopup, , , , True)
    PopUp1.Caption = "Supprimer un destinataire"
 
    Set PopUp2 = Barre.Controls.Add(msoControlPopup, , , , True)
    PopUp2.Caption = "choisir un destinataire"
 
    With Sheets("liste de nom")
        For E = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            strTag = ""
            For iCol = 1 To 6
                strTag = strTag & .Cells(E, iCol)
                If iCol < 6 Then strTag = strTag & ":"
            Next
            With PopUp2.Controls.Add(msoControlButton, , , , True)
                .Caption = Sheets("liste de nom").Cells(E, 1)
                .FaceId = 326
                .Tag = strTag
            End With
 
            With PopUp1.Controls.Add(msoControlButton, , , , True)
                .Caption = Sheets("liste de nom").Cells(E, 1)
                .FaceId = 326
                .Tag = E
                .OnAction = "suppresion_destinataire"
            End With
        Next
        'On determine l'emplacement
        'Je n'ai pas compris ou tu voulais faire apparaitre ta popup exactement
        'De plus avec le code suivant, on s'approche mais il manque un paramètre exponetiel
        'Ca doit venir de la conversion twips/pixel je pense, ca fonctionne bien sur la cellule A1 (0,0)...
        'il faut aussi faire attention au scroll de la fenêtre
        'Il serait peut-être interessant d'utiliser ActiveWindows.visibleRange pour en tenir compte
        sngTop = ActiveWindow.PointsToScreenPixelsY(Selection.Top)
        sngLeft = ActiveWindow.PointsToScreenPixelsX(Selection.Left)
        CommandBars("menudestinataire").ShowPopup sngLeft, sngTop
    End With
End Sub

[/Edit]

++
Qwaz

[patricktoulon]

je viens d'essayer ton code il est beaucoup plus propre que le miens c'est sur

et en plus ya pas d'apis

je connaissais pas "ActiveWindow.PointsToScreenPixelsY(X)"

Code :

1
2
sngTop = ActiveWindow.PointsToScreenPixelsY([g3].Top)
        sngLeft = ActiveWindow.PointsToScreenPixelsX([g3].Left)

ne donne pas tout a fait la position voulu c'est pas preci le menu est a cheval entre lacolonne "E" et la "G"

en tout cas le "active....." simplifie beaucoup les choses

on y est presque

j'ai remarqué que si j'ajoutais le width de la popup ca fonctionnais mais je ne comprend pas pourquoi je suis obligé de faire ca ????

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
 
 
Option Explicit
 
Sub MENUdestinataire2()
Dim Barre As CommandBar
Dim E As Integer, iCol As Integer
Dim PopUp1 As CommandBarControl, PopUp2 As CommandBarControl
Dim strTag As String
Dim sngTop As Integer, sngLeft As Integer
Dim largeur As Long
 
 
    'fois = True '?
 
    On Error Resume Next 'GoTo suite
    CommandBars("menudestinataire").Delete
    'suite:
    On Error GoTo 0
 
    'Cancel = True '?
    Set Barre = CommandBars.Add("menudestinataire", msoBarPopup, False, True)
 
    Set PopUp1 = Barre.Controls.Add(msoControlPopup, , , , True)
    PopUp1.Caption = "Supprimer un destinataire"
 
 
    Set PopUp2 = Barre.Controls.Add(msoControlPopup, , , , True)
    PopUp2.Caption = "choisir un destinataire"
 'des que la commandbarre est créée on recupere sa largeur dans la variable "largeur"
   largeur = CommandBars("menudestinataire").Width
 
    With Sheets("liste de nom")
        For E = 2 To .Cells(.Rows.Count, "A").End(xlUp).Row
            strTag = ""
            For iCol = 1 To 6
                strTag = strTag & .Cells(E, iCol)
                If iCol < 6 Then strTag = strTag & ":"
            Next
            With PopUp2.Controls.Add(msoControlButton, , , , True)
                .Caption = Sheets("liste de nom").Cells(E, 1)
                .FaceId = 326
                .Tag = strTag
            End With
 
            With PopUp1.Controls.Add(msoControlButton, , , , True)
                .Caption = Sheets("liste de nom").Cells(E, 1)
                .FaceId = 326
                .Tag = E
                .OnAction = "suppresion_destinataire"
            End With
        Next
        'On determine l'emplacement
        'Je n'ai pas compris ou tu voulais faire apparaitre ta popup exactement
        'De plus avec le code suivant, on s'approche mais il manque un paramètre exponetiel
        'Ca doit venir de la conversion twips/pixel je pense, ca fonctionne bien sur la cellule A1 (0,0)...
        'il faut aussi faire attention au scroll de la fenêtre
        'Il serait peut-être interessant d'utiliser ActiveWindows.visibleRange pour en tenir compte
         sngTop = ActiveWindow.PointsToScreenPixelsY([g3].Top)
        sngLeft = ActiveWindow.PointsToScreenPixelsX([g3].Left) + (largeur - [g5].Width)
        CommandBars("menudestinataire").ShowPopup sngLeft, sngTop
 
    End With
End Sub

une idée sur la question????


au plaisir

[Qwazerty]

Salut

A mon avis le width améliore la chose mais uniquement lorsque tu te trouves a "bonne distance du bord gauche, éloigne toi plus, choisi par exemple la colonne L ou M et l'erreur sera plus importante, c'est pour cela que je parlais d'erreur exponentiel (remarque l'erreur est peut-être proportionnel seulement) dans le code, plus on s’éloigne plus l'erreur est grande mais je ne trouve pas la cause de cette effet...surement du à une conversion d'unité...

++
Qwaz

[patricktoulon]

up!!

bonjour qwazerty

j'ai trouver ca:

Code :

1
2
3
4
5
6
7
8
9
10
Public Function position1() As String
Dim x, y
    x = GetDeviceCaps(GetDC(0), 88) / 72
    y = GetDeviceCaps(GetDC(0), 90) / 72
        leleft = (ActiveWindow.PointsToScreenPixelsX([g3].Left)) * x
        letop = (ActiveWindow.PointsToScreenPixelsY([g3].Top)) * y
  [a1] = letop
[b1] = leleft
position1 = leleft & "," & letop
End Function

mais ca ne donne toujour pas la bonne mesure

j'ai beau chercher j'ai du mal a comprendre pour quoi ??
pour le moment la meilleur macro qui me donne les coordonnée correctes c'est mamacro barbare celle ci:

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
 
Public Function position2() As String
x = Application.Left + 150
y = 0
Do
y = y + 1
[a1] = y
Set objet = ActiveWindow.RangeFromPoint(x, y)
If TypeName(objet) = "Range" Then
If objet.Row = 3 Then
GoTo colonne
End If
End If
DoEvents
Loop
x = 0
[b1] = x
colonne:
Do
x = x + 1
[b1] = x
Set objet = ActiveWindow.RangeFromPoint(x, y)
If TypeName(objet) = "Range" Then
If objet.Column = 7 Then
Exit Do
End If
End If
Loop
position2 = x & "," & y
x = 0
y = 0
End Function

c'est vraiment un casse tete chinois ce truc
au plaisir

[patricktoulon]

bonjour qwazerty

voila comme ca ca fonctionne mieux

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
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
 
Sub MENUdestinataire2()
    fois = True
 
    Dim Barre As CommandBar
    On Error GoTo suite
    CommandBars("menudestinataire").Delete
suite:
  On Error GoTo 0
  Cancel = True
  Set Barre = CommandBars.Add("menudestinataire", msoBarPopup, False, True)
 
  Set PopUp1 = Barre.Controls.Add(msoControlPopup, , , , True)
    With PopUp1
    .Caption = "Supprimer un destinataire"
    End With
 
 
  Set PopUp2 = Barre.Controls.Add(msoControlPopup, , , , True)
    With PopUp2
    .Caption = "choisir un destinataire"
    End With
 
 
 
    derlig = Sheets(1).Range("a65530").End(xlUp).Row
 
    For E = 2 To derlig
 
 
        With PopUp2.Controls.Add(msoControlButton, , , , True)
            .Caption = Sheets("liste de nom").Cells(E, 1)
            .FaceId = 326
            .Tag = Sheets("liste de nom").Cells(E, 1) & ":" & Sheets("liste de nom").Cells(E, 2) _
                      & ":" & Sheets("liste de nom").Cells(E, 3) & ":" & Sheets("liste de nom").Cells(E, 4) _
                      & ":" & Sheets("liste de nom").Cells(E, 5) & ":" & Sheets("liste de nom").Cells(E, 6)
            .OnAction = "dest"
        End With
 
 With PopUp1.Controls.Add(msoControlButton, , , , True)
            .Caption = Sheets("liste de nom").Cells(E, 1)
            .FaceId = 326
            .Tag = E
            .OnAction = "suppresion_destinataire"
 
        End With
 
Next
CommandBars("menudestinataire").ShowPopup position3
End Sub
 
Public Function position3()
dpi = 96#
     lelefts = ActiveWindow.PointsToScreenPixelsX([g3].Left * dpi / 72) '* ActiveWindow.Zoom / 100)
     letops = ActiveWindow.PointsToScreenPixelsY([g3].Top * dpi / 72) ' * ActiveWindow.Zoom / 100)
position3 = lelefts & "," & letops
End Function

qu'en pense tu ?

il faudrait que je comprenne la différences entre les twips,points et pixels ce qui est pour le moment que tres vagues pour moi

n'ayant pas de point de conversion comme 1 euros=6,55957 francs
alors ma question est une bonne fois pour toute

1 point est egal à (x)pixels ????
1twips est egal à (x) points ????
1twips est egal à (x) pixels ????

au ^plaisir

[Qwazerty]

Salut

http://support.microsoft.com/kb/463203/fr

En gros ce qui nous intéresse ce sont les twips et les pixels, les points ne sont utilisés que pour les polices d'écriture.
Concernant la conversion de l'un à l'autre, en vb "pure" il existe l'object Screen qui permet de connaitre le nombre de pixel contenu dans un twips. En VBA Screen n'existe pas, voila les 2 fonctions utilisées pour la conversion.

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
Option Explicit
 
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 Const HWND_DESKTOP As Long = 0
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
 
Function TwipsPerPixelX() As Single
Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    TwipsPerPixelX = 1440& / GetDeviceCaps(lngDC, LOGPIXELSX)
    ReleaseDC HWND_DESKTOP, lngDC
End Function
 
Function TwipsPerPixelY() As Single
Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    TwipsPerPixelY = 1440& / GetDeviceCaps(lngDC, LOGPIXELSY)
    ReleaseDC HWND_DESKTOP, lngDC
End Function

++
Qwaz

[patricktoulon]

merci pour les fonctions

ce que je n'arrive pas a comprendre c'est

"ActiveWindow.PointsToScreenPixelsX([g3].Left )"



devrait donner la position en pixel de la cellule g3 enfin si je me trompe pas ???

au plaisir

[Qwazerty]

Salut

J'ai trouvé ça sur le net

Code :

1
2
3
4
5
6
7
8
9
10
Bonsoir Laurent;
Quelque chose comme (à adapter en fonction de tes propres critères range et
nom de la barre d'outils):
With Range("E3")
MaBarre.Top = ActiveWindow.PointsToScreenPixelsY(.Top * 4 / 3) * 3 / 4
MaBarre.Left = ActiveWindow.PointsToScreenPixelsX(.Offset(0, 1).Left * 4 /
3) * 3 / 4
End With
 
MP

avec les 4/3 on retrouve 96/72

Et 72 correspond à la valeur retourné par TwipsParPixel (de memoire) c'est 15 (mais c'est dépendant de la résolution)

Donc en fait, la fonction PointsToScreenPixelsX demande une valeur en point et non une valeur en Twips, d'ou le besoin de d'abord convertir les Twips en points....
++
Qwaz

[patricktoulon]

resalut

oui je l'ai vu aussi celle avec le 4/3


donc pour faire une fonction propre j'ai reuni les 3

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
 
Option Explicit
 
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 Const HWND_DESKTOP As Long = 0
Private Const LOGPIXELSX As Long = 88
Private Const LOGPIXELSY As Long = 90
 
dim TwipsPerPixelX as long 
dim TwipsPerPixelY as long 
 
Function coordonnées_cellule() As String
Dim lngDC As Long
    lngDC = GetDC(HWND_DESKTOP)
    TwipsPerPixelX = GetDeviceCaps(lngDC, LOGPIXELSX)
    TwipsPerPixelY = GetDeviceCaps(lngDC, LOGPIXELSY)
    lelefts = ActiveWindow.PointsToScreenPixelsX([g3].Left * TwipsPerPixelX / 72 * ActiveWindow.Zoom / 100)
    letops = ActiveWindow.PointsToScreenPixelsY([g3].Top * TwipsPerPixelY / 72 * ActiveWindow.Zoom / 100)
    [i3] = lelefts
    [h3] = letops
    coordonnées_cellule = lelefts & "," & letops
ReleaseDC HWND_DESKTOP, lngDC
End Function

je vais encore potasser sur le sujet car j'ai pas tout assimiler mais je crois que l'on peut cliquer "Resolu"

merci a toi pour ces précisions
au plaisir