Tạo Menu Popup trong Excel với VB

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: