VBA Detail Shortcut Menu

menums-accessms-access-2010vba

I am updating some old VBA code to work with Access 2010. One problem we encountered is that no Shortcut Menu appears when you right click so we create a shortcut menu and bound it to the Application object like so…

Application.ShortcutMenuBar = "GeneralClipboardMenu"

In general this works however if you right click on a column in a Detail pane, "Which we are using as an excel grid", no menu appears. This aspect is critical to the use of our application so we can not ignore it.

Nowhere in the code are Shortcut Menus being disable. Also I realize shortcut menus are being replaced by the ribbon in the 2010 Office suit however right click is a basic feature that we would ideally like to keep.

Any help would be greatly appreciated. Here is the code for creating the shortcut menu in-case it is relevant.

Sub CreateSimpleShortcutMenu()
  On Error Resume Next 'If menu with same name exists delete
  CommandBars("GeneralClipboardMenu").Delete
  Dim cmb As CommandBar
  Set cmb = CommandBars.Add("GeneralClipboardMenu", msoBarPopup, False, False)
      With cmb
          .Controls.Add msoControlButton, 21, , , True   ' Cut
          .Controls.Add msoControlButton, 19, , , True   ' Copy
          .Controls.Add msoControlButton, 22, , , True   ' Paste
          .Controls.Add msoControlButton, 4016, , , True 'Sort Ascending
          .Controls.Add msoControlButton, 4017, , , True 'Sort Decending
      End With
  Set cmb = Nothing
End Sub

Best Answer

I believe the Application-wide Shortcut Menu bar is a DAO database property. You can change it in the GUI under Access Options > Current Database > Ribbon and Toolbar Options.

You can also change it using the following code:

UpdateCustomProperty("StartupShortcutMenuBar", "NameOfMyCustomShortcutMenuBar")

Private Function CreateCustomProperty(ByVal sPropertyName As String, _
                                        ByVal sPropertyValue As String)
    On Error Resume Next

    If sPropertyName <> "" And sPropertyValue <> "" Then
        Dim p1 As DAO.Property
        Set p1 = CurrentDb.CreateProperty(sPropertyName, DB_TEXT, sPropertyValue)
        CurrentDb.Properties.Append p1
        Set p1 = Nothing
    End If

End Function

Public Function UpdateCustomProperty(ByVal sPropertyName As String, _
                                    ByVal sPropertyValue As String)
    On Error Resume Next

    If sPropertyName <> "" And sPropertyValue <> "" Then
        CurrentDb.Properties(sPropertyName) = sPropertyValue
        If Err.Number = 3270 Then
            Err.Clear
            Call CreateCustomProperty(sPropertyName, sPropertyValue)
        End If
    End If
    Err.Clear
End Function

Related Solutions

Excel – Sending formatted Lotus Notes rich text email from Excel VBA

The short answer is Yes. The long answer is painful. There aren't any great classes exposed to manipulate rich text items in Notes. However a few that you can research are the NotesRichTextStyle, NotesRichTextParagraphStyle, and NotesRichTextTable to name a few. These classes help you define some rich text elements and add them programmatically to your rich text field.

Another approach, since you're sending email, is to use the NotesMIMEEntity classes and build the email using HTML (way way easier). Here's some sample code:

Set s = New NotesSession
Dim docMail As NotesDocument
Dim body As NotesMIMEEntity
Dim stream As NotesStream

Set db = s.CurrentDatabase
s.ConvertMIME = False ' Do not convert MIME to rich text

'Create email to be sent
Set docMail = db.CreateDocument

With docMail
        .SendTo = SEND TO ADDRESS
        .From = FROM ADDRESS
        .Principal = FROM ADDRESS
        .ReplyTo = REPLY TO ADDRESS
        .Subject = SUBJECT
        .Form = "Memo"
End With

  Set stream = s.CreateStream
Set body = docMail.CreateMIMEEntity
Call stream.WriteText ("YOUR HTML CODE GOES HERE")

'ENC_IDENTITY_8BIT used because of technote found on notes.net
'http://www-10.lotus.com/ldd/nd6forum.nsf/55c38d716d632d9b8525689b005ba1c0/aeedaf28e47546ad85256f6a000a4b48?OpenDocument
Call body.SetContentFromText (stream, "text/html;charset=iso-8859-1",ENC_IDENTITY_8BIT) 

Call docMail.Send(False)
Set docMail = Nothing
Set body = Nothing
Set stream = Nothing

s.ConvertMIME = True ' Restore conversion

Essentially you'll need to turn the ConvertMIME setting off in the NotesSession. Then create a new document, set the mail properties, etc. That part is already in your VBA code. Next, create the MIMEEntity and a stream to hold your HTML text. Finally call the SetContentFromText method on your MIMEEntity object. Then send your email. Note the last call is to turn the ConvertMIME feature back on for the NotesSession.

I'm not sure if this will all work via COM, but it does work well in LotusScript agents in Notes.

I hope this helps!

Excel – way to crack the password on an Excel VBA Project

You can try this direct VBA approach which doesn't require HEX editing. It will work for any files (*.xls, *.xlsm, *.xlam ...).

Tested and works on:

Excel 2007
Excel 2010
Excel 2013 - 32 bit version
Excel 2016 - 32 bit version

Looking for 64 bit version? See this answer

How it works

I will try my best to explain how it works - please excuse my English.

The VBE will call a system function to create the password dialog box.
If user enters the right password and click OK, this function returns 1. If user enters the wrong password or click Cancel, this function returns 0.
After the dialog box is closed, the VBE checks the returned value of the system function
if this value is 1, the VBE will "think" that the password is right, hence the locked VBA project will be opened.
The code below swaps the memory of the original function used to display the password dialog with a user defined function that will always return 1 when being called.

Using the code

Please backup your files first!

Open the file(s) that contain your locked VBA Projects

Create a new xlsm file and store this code in Module1

code credited to Siwtom (nick name), a Vietnamese developer

Option Explicit

Private Const PAGE_EXECUTE_READWRITE = &H40

Private Declare Sub MoveMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (Destination As Long, Source As Long, ByVal Length As Long)

Private Declare Function VirtualProtect Lib "kernel32" (lpAddress As Long, _
        ByVal dwSize As Long, ByVal flNewProtect As Long, lpflOldProtect As Long) As Long

Private Declare Function GetModuleHandleA Lib "kernel32" (ByVal lpModuleName As String) As Long

Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, _
        ByVal lpProcName As String) As Long

Private Declare Function DialogBoxParam Lib "user32" Alias "DialogBoxParamA" (ByVal hInstance As Long, _
        ByVal pTemplateName As Long, ByVal hWndParent As Long, _
        ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer

Dim HookBytes(0 To 5) As Byte
Dim OriginBytes(0 To 5) As Byte
Dim pFunc As Long
Dim Flag As Boolean

Private Function GetPtr(ByVal Value As Long) As Long
    GetPtr = Value
End Function

Public Sub RecoverBytes()
    If Flag Then MoveMemory ByVal pFunc, ByVal VarPtr(OriginBytes(0)), 6
End Sub

Public Function Hook() As Boolean
    Dim TmpBytes(0 To 5) As Byte
    Dim p As Long
    Dim OriginProtect As Long

    Hook = False

    pFunc = GetProcAddress(GetModuleHandleA("user32.dll"), "DialogBoxParamA")


    If VirtualProtect(ByVal pFunc, 6, PAGE_EXECUTE_READWRITE, OriginProtect) <> 0 Then

        MoveMemory ByVal VarPtr(TmpBytes(0)), ByVal pFunc, 6
        If TmpBytes(0) <> &H68 Then

            MoveMemory ByVal VarPtr(OriginBytes(0)), ByVal pFunc, 6

            p = GetPtr(AddressOf MyDialogBoxParam)

            HookBytes(0) = &H68
            MoveMemory ByVal VarPtr(HookBytes(1)), ByVal VarPtr(p), 4
            HookBytes(5) = &HC3

            MoveMemory ByVal pFunc, ByVal VarPtr(HookBytes(0)), 6
            Flag = True
            Hook = True
        End If
    End If
End Function

Private Function MyDialogBoxParam(ByVal hInstance As Long, _
        ByVal pTemplateName As Long, ByVal hWndParent As Long, _
        ByVal lpDialogFunc As Long, ByVal dwInitParam As Long) As Integer
    If pTemplateName = 4070 Then
        MyDialogBoxParam = 1
    Else
        RecoverBytes
        MyDialogBoxParam = DialogBoxParam(hInstance, pTemplateName, _
                           hWndParent, lpDialogFunc, dwInitParam)
        Hook
    End If
End Function

Paste this code under the above code in Module1 and run it

Sub unprotected()
    If Hook Then
        MsgBox "VBA Project is unprotected!", vbInformation, "*****"
    End If
End Sub

Come back to your VBA Projects and enjoy.