Tạo menu popup trong EXCEL

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

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