Right Mouse Click Menu extra functionality

[TedX]

Hi All

Some time ago, I watched a YouTube video and followed along and created some actions that happened when I used a right mouse click. Recently I wanted to add to that, but couldn't figure out the logic that made it work. In frustration whilst trying to modify it, I deleted it all and of course, can't find the video either.

I think the people in this forum are way smarter and will know a better way, trust me, the video method was really weird.

Okay so, all I want to do is land on any cell, which will have a regular number in it. I then want to right-mouse click and on the menu that opens up have 1, 2, 3, -1, -2,-3. If the contents of the cell is say 75, and I right mouse click and then left mouse click on 2, the 75 will change to 77, I could repeat the right mouse click again and left mouse click on -3 and the cell would change to 74, and so on. I had this going really well but when I did it originally, I had only -1, 1, 5. So getting all possible number changes was difficult, it would sometimes require 3 consecutive actions.

If someone can in the first instance write a macro that would get this working, that would be great. I can tell you that I had it in my Personal folder, it also had some code that switched something off on exiting Excel, and well, it was all rather weird. My second reason for asking for this is because I genuinely want to learn and I have grasped most of the things I have learned from within this forum, but this entire right mouse click thing has me stumped, perhaps I'm just thicker than the average Bear. If I can understand how I can add actions to the right mouse click menu, there are a few other things I would like to try that I could certainly use. For now, however, the numbers changing is something I do all day, every day literally hundreds of times and being a compulsive mouse man, I'd prefer to point and click than to actually hit the keyboard. TIA for any advice or code.

 

[Micron]

It has been quite a while since I did any custom commandbar or context menus but would be willing to play around. One thing you don't say is what about all the current menu items that are there in the built in menu? I think you'd either have to replace the menu and lose all of its functionality or add to the existing one.

 

[Jaafar Tribak]

Here is a example with some colorful fun added to it

1- Place this in a Standard Module :

Option Explicit

#If Win64 Then
    Private Const NULL_PTR = 0^
#Else
    Private Const NULL_PTR = 0&
#End If

Private Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

#If VBA7 Then
    Private Declare PtrSafe Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare PtrSafe Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare PtrSafe Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare PtrSafe Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare PtrSafe Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare PtrSafe Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare PtrSafe Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare PtrSafe Function EmptyClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function CloseClipboard Lib "user32" () As Long
    Private Declare PtrSafe Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare PtrSafe Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare PtrSafe Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare PtrSafe Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
#Else
    Private Enum LongPtr
        [_]
    End Enum
    Private Declare Function GetDC Lib "user32" (ByVal hwnd As LongPtr) As LongPtr
    Private Declare Function ReleaseDC Lib "user32" (ByVal hwnd As LongPtr, ByVal hDC As LongPtr) As Long
    Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDC As LongPtr, ByVal nWidth As Long, ByVal nHeight As Long) As LongPtr
    Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As LongPtr) As LongPtr
    Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As LongPtr) As Long
    Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As LongPtr) As Long
    Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As LongPtr, ByVal hObject As LongPtr) As LongPtr
    Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As LongPtr) As Long
    Private Declare Function EmptyClipboard Lib "user32" () As Long
    Private Declare Function CloseClipboard Lib "user32" () As Long
    Private Declare Function SetClipboardData Lib "user32" (ByVal wFormat As Long, ByVal hMem As LongPtr) As LongPtr
    Private Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As LongPtr
    Private Declare Function FillRect Lib "user32" (ByVal hDC As LongPtr, lpRect As RECT, ByVal hBrush As LongPtr) As Long
    Private Declare Function SetRect Lib "user32" (lpRect As RECT, ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long
#End If



Public Sub DisplayMenuPopUp()

    Dim i As Long
    Dim MenuValue As Variant
    Dim ColorFaceID As Variant
   
    On Error Resume Next
        Application.CommandBars("MyPopUpMenu").Delete
    On Error GoTo 0
   
    With Application.CommandBars.Add(Name:="MyPopUpMenu", Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
        For i = 1& To 6&
            MenuValue = Choose(i, "+1", "+2", "+3", "-1", "-2", "-3")
            ColorFaceID = Choose(i, &HFF99FF, &HCC66FF, &HFF, &HFFCC00, &HFF6600, &HFF0000)
            With .Controls.Add(Type:=msoControlButton)
                .caption = (MenuValue)
                .BeginGroup = True
                FaceID_Color CLng(ColorFaceID)
                .PasteFace
                .OnAction = "'TestMacro " & Chr(34&) & MenuValue & Chr(34&) & "'"
            End With
        Next
    End With
   
    Call OpenClipboard(NULL_PTR)
    Call EmptyClipboard
    Call CloseClipboard

    Application.CommandBars("MyPopUpMenu").ShowPopup
   
End Sub

Sub TestMacro(ByVal ChosenValue As Long)
    ActiveCell = ActiveCell + ChosenValue
End Sub

Private Sub FaceID_Color(Color As Long)

    Const CF_BITMAP = 2&
   
    Dim hDC As LongPtr, hMemDc As LongPtr
    Dim hMemBmp As LongPtr, hPrevBmp As LongPtr, hBrush As LongPtr
    Dim tRect As RECT
   
    On Error GoTo Xit
   
    Call SetRect(tRect, 0&, 0&, 16&, 16&)
    hDC = GetDC(NULL_PTR)
    hMemDc = CreateCompatibleDC(hDC)
    With tRect
        hMemBmp = CreateCompatibleBitmap(hDC, .Right - .Left, .Bottom - .Top)
    End With
    hPrevBmp = SelectObject(hMemDc, hMemBmp)
    hBrush = CreateSolidBrush(Color)
    Call FillRect(hMemDc, tRect, hBrush)
    Call OpenClipboard(NULL_PTR)
    Call EmptyClipboard
    Call SetClipboardData(CF_BITMAP, hMemBmp)
Xit:
    Call CloseClipboard
    Call SelectObject(hMemDc, hPrevBmp)
    Call DeleteObject(hMemBmp)
    Call DeleteDC(hMemDc)
    Call DeleteObject(hBrush)
    Call ReleaseDC(NULL_PTR, hDC)
   
End Sub

2- Code Usage in the ThisWorkbook Module:

Option Explicit

Private Sub Workbook_SheetBeforeRightClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    If IsNumeric(Target) Then
        Cancel = True
        Call DisplayMenuPopUp
    End If
End Sub

 

[Micron]

Somewhat simpler without all the API calls perhaps:
In module mdlCreateMenu

Option Explicit
Public intAddValue As Integer

Sub CreateMenu() 'run only once or again IF Sub Delete was run to remove menu
Dim myBar As CommandBar
Dim myItem As CommandBarControl
Dim i As Integer
Dim ary As Variant

Set myBar = Application.CommandBars.Add(Name:="RightClickAdd", Position:=msoBarPopup, Temporary:=True)

ary = Array("+3", "+2", "+1", "-1", "-2", "-3")
For i = 0 To 5
     Set myItem = myBar.Controls.Add(Type:=msoControlButton)
     With myItem ' Add a menu item
          .Caption = ary(i)
          .OnAction = "AddValue"
          ''.FaceId = 1554
     End With
Next

End Sub

Function AddValue() 'value added to cell by right click on sheet
Dim ctl As CommandBarControl

Set ctl = Application.CommandBars.ActionControl
intAddValue = CInt(ctl.Caption)
Set ctl = Nothing

End Function

Sub Delete()
Application.CommandBars("RightClickAdd").Delete
End Sub

Then on a sheet that you want the right click menu to appear on:

Private Sub Worksheet_BeforeRightClick(ByVal Target As Excel.Range, Cancel As Boolean)
On Error GoTo errHandler

CommandBars("RightClickAdd").ShowPopup
Cancel = True
Target.Value = Target.Value + intAddValue
exitHere:
Exit Sub

errHandler:
If Err.Number = 5 Then 'menu is missing so recreate
     CreateMenu
     Resume
Else
     MsgBox "Error " & ": " & Err.Description
     Resume exitHere
End If

End Sub

Not perfect but seems to work.

 

[TedX]

Thank you very much to both Jaafar Tribak and Micron, I tried the first one and it worked BOOM so impressive, I'm going to spend the rest of the night reading it line by line and trying to get the idea in my head. Sorry to Micron, I never tried your solution but appreciate the effort. I've always believed in if it ain't broke don't fix it. Here is an image of my actual sheet, with me changing the value of a horse called "Mosquito", oddly enough, LOL, horse owners are a funny lot when it comes to naming them. Anyway, the value was 73.01 and after clicking on the +2, it changed to 75.01 (see insert, lower right-hand side) exactly as expected. I can't thank you enough, this makes my daily work doable with just one hand, leaving the other hand to drink coffee Oh yeah, the colours were a nice touch

 

[Dan_W]

I appreciate that this has already been solved, but I couldn't resist adding my own (unsolicited) two cents

The approach taken below is pretty much a carbon copy of Jaafar's, but like Micron's approach, it doesn't use APIs. It uses a COM object - WIA - which is, in my opinion, a thoroughly unappreciated tool and is very, very handy for working with images. The solution below creates a white bitmap image from code (thus the weird "yMjIyMjI" text), and then changes the colour of all the pixels, finally converting it into a format that VBA understands.

Apologies again for hijacking the thread, but I just thought someone might find it useful.

Public Sub OtherDisplayMenuPopUp()
        Dim i As Long
        Dim MenuValue As Variant
        Dim ColorFaceID As Variant
       
        On Error Resume Next
            Application.CommandBars("MyPopUpMenu").Delete
        On Error GoTo 0
       
        With Application.CommandBars.Add(Name:="MyPopUpMenu", Position:=msoBarPopup, MenuBar:=False, Temporary:=True)
            For i = 1& To 6&
                MenuValue = Choose(i, "+1", "+2", "+3", "-1", "-2", "-3")
                ColorFaceID = Choose(i, &HFF99FF, &HCC66FF, &HFF, &HFFCC00, &HFF6600, &HFF0000)
                With .Controls.Add(Type:=msoControlButton)
                    .Caption = (MenuValue)
                    .Picture = CreateFaceIDBMP(CLng(ColorFaceID))
                    .OnAction = "OtherTestMacro"
                End With
            Next
        End With
        Application.CommandBars("MyPopUpMenu").ShowPopup
    End Sub
    Sub OtherTestMacro()
        ActiveCell = ActiveCell + CLng(Application.CommandBars.ActionControl.Caption)
    End Sub

    Function CreateFaceIDBMP(ByVal TargetColour As Long) As StdPicture
        Dim ImgVector As Object
        Set ImgVector = CreateObject("WIA.Vector")
        Dim Node As Object
        Set Node = CreateObject("Msxml2.DOMDocument.3.0").createElement("base64")
        Dim Counter As Long
        Node.DataType = "bin.base64"
        Node.Text = "Qk02AwAAAAAAADYAAAAoAAAAEAAAABAAAAABABgAAAAAAAADAAAAAAAAAAAAAAAAAAAAAAAA" & WorksheetFunction.Rept("yMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjIyMjI" & vbNewLine, 14) & "yMjIyMjIyMjIyMjI"
        
        With ImgVector
            .BinaryData = Node.nodeTypedValue
            For Counter = 55 To UBound(.BinaryData) Step 3
                .Item(Counter) = (TargetColour \ 65536) Mod 256
                .Item(Counter + 1) = (TargetColour \ 256) Mod 256
                .Item(Counter + 2) = (TargetColour Mod 256)
            Next
            Set CreateFaceIDBMP = .Picture
        End With
        Set Node = Nothing
    End Function

 

[Jaafar Tribak]

Very cool Dan_W

An added bonus to your code is that it doesn't use\clear the clipboard which my code does because I used the PasteFace Method instead of using the Picture Property. I too should have used the Picture Property by assigning to it the valid memory bitmap handle w\o messing withe clipboard .

Can you suggest some reading material about WIA destined to VB(A) users ?

Thanks.

 

[Dan_W]

I'm glad you like it. I actually didn't see that you had used the clipboard - I just saw the APIs and thought "aha! I've got another way!". This subroutine is a derivative of one I wrote after seeing something you wrote here about being able to change the background of a multipage control by using a picture. So my code for that was to make a single pixel (the above code is 16x16pixels) and then use the Stretch feature.

There is a lot you can do with it - I use it regularly to load PNG files into the Picture property of various controls, but you can use it to (1) convert images from one format to another; (2) resize; (3) crop; (4) flip/mirror; (5) read/write exif metadata to JPG files (which I posted on this forum, but I just need to find the link); (6) stamp an image onto another, (7) extract frames from an animated GIF (which is what I've been working on recently), etc. There's a lot.

Microsoft used to have a help file (CHM?) with the COM object explained in detail, with examples, but it's not available on their site. I did come across a copy of it on a now defunct website through Internet Archive - I will see if I can find it. Part of it still exists on the MS website in text form, but help file is more helpful (pun intended).

But I think the best resource is Dilettante on VBForums. He has written a fair few posts (and I think a few things in the codebank) using WIA. I think I have a list of links somewhere. Will have to get back to you on that, and will of course post it here in the forum in case of interest to others.

 

[Micron]

I've used WIA to flip and rotate images for a db project. Sadly, I lost it all when I dropped my laptop. Stupid me didn't have a backup elsewhere. Trying to work up the gumption to re-create it, but not succeeding so far.

 

[Micron]

2 search results

About Microsoft Windows Image Acquisition Automation Layer

The Windows Image Acquisition (WIA) Automation Layer is a high-quality, full-featured image manipulation component that provides end-to-end image processing capabilities for Microsoft Visual Basic 6.0, Active Server Pages (ASP), and scripting languages.

learn.microsoft.com

Shared Samples

This topic contains a number of code examples that show how to accomplish various tasks.

learn.microsoft.com