Sub showpop(quoi As Variant, boutons)
Dim obj, L#, t#, e&, barre, ActW, opw
Set obj = quoi
opw = Val(Trim(Split(Application.OperatingSystem, "(")(1)))
Set ActW = IIf(opw = 32, ActiveWindow.ActivePane, ActiveWindow)
With ActW
L = .PointsToScreenPixelsX(obj.Left + obj.Width)
t = .PointsToScreenPixelsY(obj.Top)
End With
On Error Resume Next
CommandBars("monmenu").Delete
Err.Clear
Set barre = CommandBars.Add("monmenu", msoBarPopup, False, True)
With barre
For e = 0 To UBound(boutons)
If Not IsArray(boutons(e)) Then
With barre.Controls.Add(msoControlButton, 1, , , True)
.Caption = Split(boutons(e), ":")(0)
.FaceId = Split(boutons(e), ":")(1)
.OnAction = Split(boutons(e), ":")(2)
End With
Else
With barre.Controls.Add(msoControlPopup, 1, , , True)
.Caption = boutons(e)(0)
For i = 1 To UBound(boutons(e))
With .Controls.Add(msoControlButton, 1, , , True)
.Caption = Split(boutons(e)(i), ":")(0)
.FaceId = Split(boutons(e)(i), ":")(1)
.OnAction = Split(boutons(e)(i), ":")(2)
End With
Next
End With
End If
Next
End With
barre.ShowPopup L, t
On Error Resume Next
CommandBars("monmenu").Delete
End Sub
Private Sub CommandButton1_Click()
showpop CommandButton1, Array("youky(BJ):256:youki", "jcf6464:148:jcf6464", Array("submenu", "bt1:55:bt1", "bt2:763:bt2"), "ChTi160:387:ChTi160", "patricktoulon:583:patricktoulon")
End Sub
Private Sub CommandButton1_Click()
showpop CommandButton1
Range("A1").Select ' ****ligne rajouté
End Sub
Function placementRange(Obj As Range)
If Obj Is Nothing Then Exit Function
Dim z#, EcX#, L1#, T1#, C#, R#, Vr As Range, Hx#, Wx#, Ok As Boolean, Op&, PtoPx#, I&
With ActiveWindow
PtoPx = (.ActivePane.PointsToScreenPixelsX(72) - .ActivePane.PointsToScreenPixelsX(0)) / 72 'coeff point to pixel
Op = Int(Val(Mid(Application.OperatingSystem, InStrRev(Application.OperatingSystem, " ") + 1))) 'number version system
'exit si la cellule injecté n'est pas vible a l'ecran
For I = 1 To .Panes.Count: Ok = IIf(Not Intersect(.Panes(I).VisibleRange, Obj) Is Nothing, True, Ok): Next
If Ok = False Then Beep: MsgBox " cette cellule n'est pas visible a l'ecran": Exit Function
z = (ActiveWindow.Zoom / 100): Set Vr = .VisibleRange 'Coeff zoom , rangevisible partie mobile
EcX = 4 And Op = 6 And Int(Val(Application.Version)) < 16 'ecart cadre
L1 = (.ActivePane.PointsToScreenPixelsX(Int(Obj.Left)) / PtoPx) * z + EcX 'placement partie mobile
T1 = .ActivePane.PointsToScreenPixelsY(Int(Obj.Top)) / PtoPx * z + EcX
With .Panes(1).VisibleRange: C = .Cells(.Cells.Count).Column: R = .Cells(.Cells.Count).Row: End With 'limite splitrow et splitcolumn
If .SplitRow > 0 Then 'placement dans le splitrow
If Obj.Row < R + 1 And .ScrollRow > R Then T1 = ((.ActivePane.PointsToScreenPixelsY(Vr.Cells(1).Top) / PtoPx) * z) - (Range(Obj, Cells(R, 1)).Height * z) + EcX
End If
If .SplitColumn > 0 Then 'placement dans le splitcolumn
If Obj.Column < C + 1 And .ScrollColumn > C Then L1 = ((.ActivePane.PointsToScreenPixelsX(Vr.Cells(1).Left) / PtoPx) * z) - (Range(Obj, Cells(1, C)).Width * z) + EcX
End If
End With
'option de placement :
L1 = L1 * PtoPx
T1 = T1 * PtoPx
placementRange = Array(L1, T1)
End Function
Sub showpop(quoi As Range, boutons)
Dim Obj As Range, L#, t#, e&, barre, ActW, opw
Set Obj = quoi
opw = Val(Trim(Split(Application.OperatingSystem, "(")(1)))
Set ActW = IIf(opw = 32, ActiveWindow.ActivePane, ActiveWindow)
With ActW
L = .PointsToScreenPixelsX(Obj.Left + Obj.Width)
t = .PointsToScreenPixelsY(Obj.Top)
End With
On Error Resume Next
CommandBars("monmenu").Delete
Err.Clear
Set barre = CommandBars.Add("monmenu", msoBarPopup, False, True)
With barre
For e = 0 To UBound(boutons)
If Not IsArray(boutons(e)) Then
With barre.Controls.Add(msoControlButton, 1, , , True)
.Caption = Split(boutons(e), ":")(0)
.FaceId = Split(boutons(e), ":")(1)
.OnAction = Split(boutons(e), ":")(2)
End With
Else
With barre.Controls.Add(msoControlPopup, 1, , , True)
.Caption = boutons(e)(0)
For I = 1 To UBound(boutons(e))
With .Controls.Add(msoControlButton, 1, , , True)
.Caption = Split(boutons(e)(I), ":")(0)
.FaceId = Split(boutons(e)(I), ":")(1)
.OnAction = Split(boutons(e)(I), ":")(2)
End With
Next
End With
End If
Next
End With
pos = placementRange(Obj)
barre.ShowPopup pos(0), pos(1)
On Error Resume Next
CommandBars("monmenu").Delete
End Sub
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
showpop Target, Array("youky(BJ):256:youki", "jcf6464:148:jcf6464", Array("submenu", "bt1:55:bt1", "bt2:763:bt2"), "ChTi160:387:ChTi160", "patricktoulon:583:patricktoulon")
Cancel = True
End Sub
Option Explicit
Public Const XName As String = "MyPopUpMenu"
Private Sub DeleteMyCommandBar() ' Supprimer le menu s'il existe
'Dim xBar As CommandBar
'Set xBar = CommandBars(Xname)
'
'If Not xBar Is Nothing Then
' xBar.Delete
' Set xBar = Nothing
'End If
On Error Resume Next
Application.CommandBars(XName).Delete
On Error GoTo 0
End Sub
Public Sub RigthClickButtonMousse()
Call DeleteMyCommandBar ' Supprimer le menu s'il existe
Call MyCommandBar ' Créer
On Error Resume Next
Application.CommandBars(XName).ShowPopup ' Show
On Error GoTo 0
End Sub
Private Sub MyCommandBar() ' Créer
Dim MenuItem As CommandBarPopup
Dim SubMenuItem As CommandBarPopup
With Application.CommandBars.Add(Name:=XName, Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
'(1)***** Add buttons & textbox
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "Mon titre ici 1"
.FaceId = 55
.Enabled = True
.OnAction = "menuC"
End With
'(1.1)***** Add buttons
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "Mon titre ici 2"
.FaceId = 3627
' POUR AJOUTER UNE ICÔNE D'IMAGE À PARTIR D´UN DOSSIER DU PC
' .Picture = stdole.StdFunctions.LoadPicture("C:\...\document-properties-18.jpg")
.Enabled = False
.OnAction = "'" & ThisWorkbook.Name & "'!" & "MonMacro3"
End With
'(1.2)***** Add textbox
With .Controls.Add(Type:=msoControlEdit)
.BeginGroup = False
.Caption = "Unlock"
.Enabled = True
.OnAction = "getText"
End With
'(2)***** Add menu with buttons & submenu
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "Aide moi s'il te plait!"
'(2.1)***** Add submenu with buttons
Set SubMenuItem = .Controls.Add(Type:=msoControlPopup)
With SubMenuItem
.Caption = "Mon titre ici 5"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Étape 1:" & vbCrLf & "• Mon texte numéro 1 ici!"
.FaceId = 1954
' .OnAction = ""
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Étape 2:" & vbCrLf & "• Mon texte numéro 2 ici!"
.FaceId = 1954
' .OnAction = ""
End With
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "Étape 3:" & Chr(10) & "• Mon texte numéro 3 ici!"
.FaceId = 1954
' .OnAction = ""
End With
End With
'(2.2)***** Add buttons
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "S 'identifier"
.FaceId = 984
.OnAction = "MonMacro1"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Mon titre ici 7"
.FaceId = 984
.OnAction = "MonMacro2"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Cod"
.FaceId = 3627
' .OnAction = "MonMacro2"
.Enabled = False
End With
End With
'(3)****** Add button
With .Controls.Add(Type:=msoControlButton)
.BeginGroup = True
.Caption = "Mon titre ici 9"
.FaceId = 1175
' .OnAction = "'" & ThisWorkbook.Name & "'!" & "MonMacro4"
.OnAction = "MonMacro4"
End With
End With
If Not MenuItem Is Nothing Then Set MenuItem = Nothing
If Not SubMenuItem Is Nothing Then Set SubMenuItem = Nothing
End Sub
Private Sub menuC()
Dim txt As String
txt = "Bonjour à tous"
Application.Speech.Speak (txt)
End Sub
Private Function getText()
Dim str As String
Static xCount As Integer
str = CommandBars(XName).Controls("Unlock").Text
xCount = xCount + 1
Debug.Print xCount
Select Case str
Case 1234
MsgBox "• Option non disponible dans cette version du programme!", vbExclamation, "Information!"
Case Else
MsgBox "• Vous avez entré: " & (str) & vbCrLf & vbCrLf & " • Mauvaise réponse, autorisation refusée! " _
& vbCrLf & vbCrLf & "• Tentatives utilisées: (" & xCount & ") de tentatives inconnues...!", vbCritical, "Information!"
End Select
End Function
Private Sub MonMacro1()
MsgBox "• Mon message numéro un!", vbInformation, "Information!"
End Sub
Private Sub MonMacro2()
MsgBox "• Mon message numéro deux!", vbExclamation, "Information!"
End Sub
Private Sub MonMacro3()
MsgBox "• Mon message numéro trois!", vbCritical, "Information!"
End Sub
Public Sub MonMacro4()
MsgBox "• Mon message numéro quatre!", vbQuestion, "Information!"
End Sub
' CommandBar Control ID - Ma Description
'---------------------------------------------------------------------------------------
' ... ... 3 - disquette violette
' ... ... 4 - imprimante
' ... ... 5 - feuille avec des lignes
' ... ... 8 - feuille Excel grise
' ... ... 9 -2 colonnes de lignes bleues
' ... ... 11 - nombre de paragraphes (nombres)
' ... ... 12 - nombre de paragraphes (carrés bleus)
' ... ... 17 - graphique à barres
' ... ... 18 - drap blanc
' ... ... 29 - empreintes de chaussures
' ... ... 33 - montre analogique bleue
' ... ... 39 - flèche bleue droite
' ... ... 41 - flèche bleue gauche
' ... ... 42 - doc Word
' ... ... 50 - calculatrice grise
' ... ... 51 - stop gant blanc
' ... ... 52 - tirelire cochon
' ... ... 55 -3 traits noirs horizontaux
' ... ... 59 - :) JAUNE
' numbers 0 70 - 0 & bold
' numbers 1 71 - 1 & bold
' numbers 2 72 - 2 & bold
' numbers 3 73 - 3 & bold
' numbers 4 74 - 4 & bold
' numbers 5 75 - 5 & bold
' numbers 6 76 - 6 & bold
' numbers 7 77 - 7 & bold
' numbers 8 78 - 8 & bold
' numbers 9 79 - 9 & bold
' letters A 80 - A & bold
' letters B 81 - B & bold
' letters C 82 - C & bold
' letters D 83 - D & bold
' letters E 84 - E & bold
' letters F 85 - F & bold
' letters G 86 - G & bold
' letters H 87 - H & bold
' letters I 88 - I & bold
' letters J 89 - J & bold
' letters K 90 - K & bold
' letters ... ... - ...
' letters K 105 - Z & bold
' Basic Shapes &Smiley Face 1131 - :)
' Basic Shapes &Heart 1141 -
' Basic Shapes &Lightning Bolt 1140 -
' Basic Shapes &Sun 2634 -
' Basic Shapes &Moon 2635 -
' Visual Basic Security 3627 -
' External Data &Refresh Status 1954 -
' Forms &Label 476 - Aa
' Forms &Edit Box 219 - label & aa
' Forms &Group Box 467 - xyz & janela
' Forms &Button 282 - command button
' Forms &Check Box 220 - check button
' Forms &Option Button 446 - option button
' Forms &List Box 448 - listbox
' Forms &Combo Box 221 - combobox
' Forms &Combination List-Edit 471 - listbox
' Forms &Combination Drop-Down Edit 475 - drop down combobox
' Forms &Scroll Bar 447 - scroll bar
' Forms &Spinner 468 - spin buttons
' Forms Control Properties 222 - janela & 2 menus
' Forms &Code 488 - code & pag
' Forms &Run Dialog 470 - quadrado & interuptor button
' Button Cu&t 21 - ciseaux
' Button &Copy 19 - deux feuilles
' Button &Paste 22 - planche et feuille
' Button Clear 47 - gomme à effacer
' Button Edit Object 961 - feuille et haut-parleur
' Button &Format Object 962 - peinture bleue et pinceau bleu
' Button Bring to Fron&t 166 - envoyer en avant
' Button Send to Bac&k 167 -
' Button &Group 164 - group objects
' Tools &Spelling 2 - abc
' Tools &AutoCorrect 793 -
' Tools S&hare Workbook 2040 -
' Tools Add-&Ins 943 - settings
' Insert C&ells 295 -
' Insert &Rows 296 -
' Insert &Columns 297 -
' Insert &Worksheet 852 -
' Insert C&hart 1957 -
' Insert Page &Break 509 -
' Insert &Function 385 -
' Insert &Object 546 -
' View &Normal 723 -
' View &Page Break Preview 724 -
' View &Comments 1594 -
' View Custom &Views 950 -
' View F&ull Screen 178 -
' View &Zoom 925 -
' Edit &Undo 128 -
' Edit &Repeat 37 -
' Edit Cu&t 21 -
' Edit &Copy 19 -
' Edit &Paste 22 -
' Edit Paste &Special 755 -
' Edit &Delete 478 -
' Edit De&lete Sheet 847 -
' Edit &Find 1849 -
' Edit &Go To 757 -
' Edit Lin&ks 759 -
' Help Microsoft Excel &Help 984 - ?
' Help Office on the &Web 375 - "_"
' Help What 's &This? 124 - cursor & ?
' Help &About Microsoft Excel 927 - ?
' File &New 18 -
' File &Open 23 -
' File &Close 106 -
' File &Save 3 -
' File Save &As 748 -
' File Save As Web Pa&ge 3823 -
' File Save &Workspace 846 -
' File We&b Page Preview 3655 -
' File Page Set&up 247 -
' File Print Pre&view 109 -
' File &Print 4 -
' File Propert&ies 750 -
' File E&xit 752 -
' Block Arrows &Right Arrow 1142
' Block Arrows &Left Arrow 1143
' Block Arrows &Up Arrow 1144
' Block Arrows &Down Arrow 1145
' Block Arrows &Left-Right Arrow 1146
' Block Arrows &Up-Down Arrow 1147
' Block Arrows &Quad Arrow 1148
' Block Arrows &Left-Right-Up Arrow 1149
' Block Arrows &Bent Arrow 1152
' Block Arrows &U-Turn Arrow 1153
' Block Arrows &Left-Up Arrow 1150
' Block Arrows &Bent-Up Arrow 1151
' Block Arrows &Curved Right Arrow 1160
' Block Arrows &Curved Left Arrow 1161
' Block Arrows &Curved Up Arrow 1162
' Block Arrows &Curved Down Arrow 1163
' Block Arrows &Striped Right Arrow 1154
' Block Arrows &Notched Right Arrow 1155
' Block Arrows &Pentagon 1156
' Block Arrows &Chevron 1157
' Block Arrows &Right Arrow Callout 1164
' Block Arrows &Left Arrow Callout 1165
' Block Arrows &Up Arrow Callout 1166
' Block Arrows &Down Arrow Callout 1167
' Block Arrows &Left-Right Arrow Callout 1168
' Block Arrows &Up-Down Arrow Callout 1169
' Block Arrows &Quad Arrow Callout 1170
' Block Arrows &Circular Arrow 1158
'
' Stars & Banners &Explosion 1 1188
' Stars & Banners &Explosion 2 1189
' Stars & Banners &4-Point Star 2638
' Stars & Banners &5-Point Star 1183
' Stars & Banners &8-Point Star 1184
' Stars & Banners &16-Point Star 1185
' Stars & Banners &24-Point Star 1186
' Stars & Banners &32-Point Star 1187
' Stars & Banners &Up Ribbon 1180
' Stars & Banners &Down Ribbon 1179
' Stars & Banners &Curved Up Ribbon 1182
' Stars & Banners &Curved Down Ribbon 1181
' Stars & Banners &Vertical Scroll 1127
' Stars & Banners &Horizontal Scroll 1128
' Stars & Banners &Wave 1125
' Stars & Banners &Double Wave 2639
' Callouts &Rectangular Callout 1172
' Callouts &Rounded Rectangular Callout 1173
' Callouts &Oval Callout 1174
' Callouts &Cloud Callout 1175
' Callouts &Line Callout 1 1219
' Callouts &Line Callout 2 1176
' Callouts &Line Callout 3 1177
' Callouts &Line Callout 4 1178
' Callouts &Line Callout 1 (Accent Bar) 1220
' Callouts &Line Callout 2 (Accent Bar) 1221
' Callouts &Line Callout 3 (Accent Bar) 1222
' Callouts &Line Callout 4 (Accent Bar) 1223
' Callouts &Line Callout 1 (No Border) 1224
' Callouts &Line Callout 2 (No Border) 1225
' Callouts &Line Callout 3 (No Border) 1226
' Callouts &Line Callout 4 (No Border) 1227
Option Explicit
Private Sub UserForm_MouseMove(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
If Button = 2 Then ' le numéro 2 est le bouton droit de la souris
Call RigthClickButtonMousse
End If
End Sub