TẠO MENU POPUP TRONG EXCEL

• 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:

Option Explicit

Public Const gc_Title = "PopUp Menu Demo"
Public gcBar_RgtClkMenu As CommandBar

'' ***************************************************************************
'' Mục đích : 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 chopopup menu
Const lcon_PuName = "PopUpDemo"

''Tạo các đối tượng 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 thử một số 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 nó 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

'' ***************************************************************************
'' Mục đích : Nó sẽ được kích hoạt 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
''User clicked "Yes", so run it
RunMeToGetThingsGoing
MsgBox "Now try again", vbInformation + vbOKOnly, gc_Title
End If

''Thoát
Resume Worksheet_BeforeRightClick_Resume

End Sub

Lần đầu khi bạn Right Click thì bạn sẽ nhận được thông báo sau:

Sau đó 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@pmail.vnn.vn

PcLeHoan 1996 - 2002
Mirror : http://www.pclehoan.com
Mirror : http://www.lehoanpc.net
Mirror : http://www.ktlehoan.com