- Tham gia
- 30/5/06
- Bài viết
- 1,630
- Được thích
- 17,440
- Nghề nghiệp
- Bác sĩ
Menu Pop-Up
Mục đích: Tạo menu popup khi người dùng Right-Click khi chuột trong vùng làm việc của một worksheet.
Giả sử workbook của tôi có một worksheet, thì trong ví dụ của tôi có hai đoạn mã. Đoạn thứ nhất nằm trong Module VBA: PopupMenu và đoạn mã thứ hai nằm trong module worksheet: workhere
Đây là đoạn mã trong module VBA PopupMenu:
Mã:
Option Explicit
Public Const gc_Title = "PopUp Menu Demo"
Public gcBar_RgtClkMenu As CommandBar
' ************************************************** *************************
' Muc dich: Gọi hàm tạo popup menu người dùng
'
Sub RunMeToGetThingsGoing()
Set gcBar_RgtClkMenu = CreateSubMenu
End Sub
' ************************************************** *************************
' Hàm tạo popup menu
'
Function CreateSubMenu() As CommandBar
'đặt tên cho popup menu
Const lcon_PuName = "PopUpDemo"
'Tạo các đối tượng cho cho popup menu
Dim cb As CommandBar
Dim cbc As CommandBarControl
'Chắc chắn rằng popup menu không tồn tại
DeleteCommandBar lcon_PuName
'Thêm popup menu người dùng cho tập họp (collection) CommandBars
Set cb = CommandBars.Add(Name:=lcon_PuName, Position:=msoBarPopup, MenuBar:=False, Temporary:=False)
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
' Thêm vào controls
Set cbc = cb.Controls.Add
With cbc
.Caption = "&Control 1"
.OnAction = "DummyMessage"
End With
Set cbc = cb.Controls.Add
With cbc
.Caption = "Control &2"
.OnAction = "DummyMessage"
End With
' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Set CreateSubMenu = cb
End Function
' ************************************************** *************************
' Mục đích: Kiểm tra nếu command bar có tên menuName?
' Nếu tồn tại thì xóa đi
'
Sub DeleteCommandBar(menuName)
Dim mb
For Each mb In CommandBars
If mb.Name = menuName Then
CommandBars(menuName).Delete
End If
Next
End Sub
Sub DummyMessage()
MsgBox "Hello", vbInformation + vbOKOnly, gc_Title
End Sub
Đây là đoạn mã trong worksheet module: workhere
Option Explicit
' ************************************************** *************************
' Muc đích : Nó sẽ được kích họat khi người dùng Right click
' ************************************************** *************************
Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
On Error GoTo Worksheet_BeforeRightClick_Error
'Hiện popup menu người dùng
gcBar_RgtClkMenu.ShowPopup
Worksheet_BeforeRightClick_Resume:
'Nhằm ngăn chặn popup menu mặc định của Excel
Cancel = True
'Thoát khỏi thủ tục
Exit Sub
Worksheet_BeforeRightClick_Error:
'Nếu macro khởi tạo chưa chạy
'Hỏi người dùng có muốn chạy bây giờ không?
If vbYes = MsgBox("You need to run the macro " _
& "RunMeToGetThingsGoing" _
& " before this demo will work" & vbCrLf _
& vbCrLf & "Run it now?", vbQuestion + vbYesNo, gc_Title) Then
'Nếu người dùng click "Yes", thì chạy
RunMeToGetThingsGoing
MsgBox "Bây giờ thử lại", vbInformation + vbOKOnly, gc_Title
End If
''Thoát
Resume Worksheet_BeforeRightClick_Resume
End SubSau đó nếu bạn chọn Yes thì bạn sẽ nhận được thông báo sau:
Cuối cùng bạn thử Right Click lại thì bạn sẽ nhận được popup menu sau:
Chúc các bạn thành công. Hy vọng bài viết trên sẽ giúp ích các bạn phần nào.
Mọi góp ý của các bạn xin gởi cho tôi theo địa chỉ email sau:
levanduyet@yahoo.com
Chỉnh sửa lần cuối bởi điều hành viên:
, bạn nào cần mail cho mình mình gửi source cho, trên này mình ko biết attach file chỗ nào hehe 
