AbbasSediqi
جمعه 15 مرداد 1395, 14:05 عصر
برای این کار باید اول Microsoft Office xx Object Library رو اضافه کنید ( البته xx ورژن آفیسه مثال 15.0 )
یک Model در برنامه ایجاد و این کد ها را درون آن قرار دهید البته برای شخصی سازی هم یکم وقت بزارید
Option Explicit
Public Const Mname As String = "MyPopUpMenu"
Sub DeletePopUpMenu()
' Delete the popup menu if it already exists.
On Error Resume Next
Application.CommandBars(Mname).Delete
On Error GoTo 0
End Sub
Sub CreateDisplayPopUpMenu()
' Delete any existing popup menu.
Call DeletePopUpMenu
' Create the popup menu.
Call ADD_PopUpMenu
' Display the popup menu.
On Error Resume Next
Application.CommandBars(Mname).ShowPopup
On Error GoTo 0
End Sub
Sub ADD_PopUpMenu()
Dim MenuItem
' Add the popup menu.
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
' First, add two buttons to the menu.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1"
.FaceID = 59
.OnAction = "TestMacro"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2"
.FaceID = 72
.OnAction = "TestMacro"
End With
' Next, add a menu that contains two buttons.
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1 in menu"
.FaceID = 71
.OnAction = "TestMacro"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2 in menu"
.FaceID = 72
.OnAction = "TestMacro"
End With
End With
' Finally, add a single button.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 3"
.FaceID = 73
.OnAction = "TestMacro"
End With
End With
End Sub
Sub TestMacro()
MsgBox "AbbasSediqi Say Hello"
End Sub
مثال برای فراخوانی
Private Sub Text2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
CreateDisplayPopUpMenu
End If
End Sub
نمونه فایل هم قرار دادم
یا حق
یک Model در برنامه ایجاد و این کد ها را درون آن قرار دهید البته برای شخصی سازی هم یکم وقت بزارید
Option Explicit
Public Const Mname As String = "MyPopUpMenu"
Sub DeletePopUpMenu()
' Delete the popup menu if it already exists.
On Error Resume Next
Application.CommandBars(Mname).Delete
On Error GoTo 0
End Sub
Sub CreateDisplayPopUpMenu()
' Delete any existing popup menu.
Call DeletePopUpMenu
' Create the popup menu.
Call ADD_PopUpMenu
' Display the popup menu.
On Error Resume Next
Application.CommandBars(Mname).ShowPopup
On Error GoTo 0
End Sub
Sub ADD_PopUpMenu()
Dim MenuItem
' Add the popup menu.
With Application.CommandBars.Add(Name:=Mname, Position:=msoBarPopup, _
MenuBar:=False, Temporary:=True)
' First, add two buttons to the menu.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1"
.FaceID = 59
.OnAction = "TestMacro"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2"
.FaceID = 72
.OnAction = "TestMacro"
End With
' Next, add a menu that contains two buttons.
Set MenuItem = .Controls.Add(Type:=msoControlPopup)
With MenuItem
.Caption = "My Special Menu"
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 1 in menu"
.FaceID = 71
.OnAction = "TestMacro"
End With
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 2 in menu"
.FaceID = 72
.OnAction = "TestMacro"
End With
End With
' Finally, add a single button.
With .Controls.Add(Type:=msoControlButton)
.Caption = "Button 3"
.FaceID = 73
.OnAction = "TestMacro"
End With
End With
End Sub
Sub TestMacro()
MsgBox "AbbasSediqi Say Hello"
End Sub
مثال برای فراخوانی
Private Sub Text2_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = 2 Then
CreateDisplayPopUpMenu
End If
End Sub
نمونه فایل هم قرار دادم
یا حق