Results 1 to 5 of 5

Thread: 64 Bit 2016 Right Click Context Menu (User Form)
Thanks Thanks: 0 Likes Likes: 0

  1. #1
    Board Regular
    Join Date
    Dec 2015
    Posts
    62
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default 64 Bit 2016 Right Click Context Menu (User Form)

    Hello:

    I am currently using Excel 2016 (64 Bit). I opened a workbook that is a few years old with a user form that used to have a context menu upon right clicking fields.

    I am no longer able to show the context menu with the below error:

    "Compile error:

    The code in this project must be updated for use on 64-bit systems. Please review and update Declare statements and then mark them with the PtrSafe attribute."


    An example of the red highlighted error text from the code is:

    "Private Declare Function CreatePopupMenu Lib "user32" () As Long"

    I have added the PtrSafe attribute and the error goes away:

    "Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long"

    But when I open the user form, I still cannot display the context menu when right clicking.

    Is there existing 64 bit context menu code?




    Here is my PopupMenu code:

    Code:
    'This macro is for the creation of the right click menu used in the userform textboxesOption Explicit
    
    
    ' Required API declarations
    Private Declare PtrSafe Function CreatePopupMenu Lib "user32" () As Long
    Private Declare PtrSafe Function InsertMenuItem Lib "user32" Alias "InsertMenuItemA" (ByVal hMenu As Long, ByVal un As Long, ByVal bool As Boolean, ByRef lpcMenuItemInfo As MENUITEMINFO) As Long
    Private Declare PtrSafe Function TrackPopupMenu Lib "user32" (ByVal hMenu As Long, ByVal wFlags As Long, ByVal X As Long, ByVal Y As Long, ByVal nReserved As Long, ByVal hwnd As Long, lprc As RECT) As Long
    Private Declare PtrSafe Function DestroyMenu Lib "user32" (ByVal hMenu As Long) As Long
    Private Declare PtrSafe Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
    Private Declare PtrSafe Function GetCursorPos Lib "user32" (lpPoint As POINTAPI) As Long
    
    
    ' Type required by TrackPopupMenu although this is ignored !!
    Private Type RECT
            Left As Long
            Top As Long
            Right As Long
            Bottom As Long
    End Type
    
    
    ' Type required by InsertMenuItem
    Private Type MENUITEMINFO
        cbSize As Long
        fMask As Long
        fType As Long
        fState As Long
        wID As Long
        hSubMenu As Long
        hbmpChecked As Long
        hbmpUnchecked As Long
        dwItemData As Long
        dwTypeData As String
        cch As Long
    End Type
    
    
    ' Type required by GetCursorPos
    Private Type POINTAPI
            X As Long
            Y As Long
    End Type
    
    
    ' Constants required by TrackPopupMenu
    Private Const TPM_LEFTALIGN = &H0&
    Private Const TPM_TOPALIGN = &H0
    Private Const TPM_RETURNCMD = &H100
    Private Const TPM_RIGHTBUTTON = &H2&
    
    
    ' Constants required by MENUITEMINFO type
    Private Const MIIM_STATE = &H1
    Private Const MIIM_ID = &H2
    Private Const MIIM_TYPE = &H10
    Private Const MFT_STRING = &H0
    Private Const MFT_SEPARATOR = &H800
    Private Const MFS_DEFAULT = &H1000
    Private Const MFS_ENABLED = &H0
    Private Const MFS_GRAYED = &H1
    
    
    ' Contants defined by me for menu item IDs
    Private Const ID_Cut = 101
    Private Const ID_Copy = 102
    Private Const ID_Paste = 103
    Private Const ID_Delete = 104
    Private Const ID_SelectAll = 105
    
    
    
    
    ' Variables declared at module level
    Private FormCaption As String
    Private Cut_Enabled As Long
    Private Copy_Enabled As Long
    Private Paste_Enabled As Long
    Private Delete_Enabled As Long
    Private SelectAll_Enabled As Long
    
    
    Public Sub ShowPopup(oForm As UserForm, strCaption As String, X As Single, Y As Single)
    
    
        Dim oControl As MSForms.TextBox
        Static click_flag As Long
        
        ' The following is required because the MouseDown event
        ' fires twice when right-clicked !!
        click_flag = click_flag + 1
            
        ' Do nothing on first firing of MouseDown event
        If (click_flag Mod 2 <> 0) Then Exit Sub
                    
        ' Set object reference to the textboxthat was clicked
        Set oControl = oForm.ActiveControl
            
        ' If click is outside the textbox, do nothing
        If X > oControl.Width Or Y > oControl.Height Or X < 0 Or Y < 0 Then Exit Sub
        
        ' Retrieve caption of UserForm for use in FindWindow API
        FormCaption = strCaption
        
        ' Call routine that sets menu items as enabled/disabled
        Call EnableMenuItems(oForm)
        
        ' Call function that shows the menu and return the ID
        ' of the selected menu item. Subsequent action depends
        ' on the returned ID.
        Select Case GetSelection()
            Case ID_Cut
                oControl.Cut
            Case ID_Copy
                oControl.Copy
            Case ID_Paste
                oControl.Paste
            Case ID_Delete
                oControl.SelText = ""
            Case ID_SelectAll
                With oControl
                    .SelStart = 0
                    .SelLength = Len(oControl.Text)
                End With
        End Select
    
    
    End Sub
    
    
    Private Sub EnableMenuItems(oForm As UserForm)
    
    
        Dim oControl As MSForms.TextBox
        Dim oData As DataObject
        Dim testClipBoard As String
        
        On Error Resume Next
        
        ' Set object variable to clicked textbox
        Set oControl = oForm.ActiveControl
        
        ' Create DataObject to access the clipboard
        Set oData = New DataObject
        
        ' Enable Cut/Copy/Delete menu items if text selected
        ' in textbox
        If oControl.SelLength > 0 Then
            Cut_Enabled = MFS_ENABLED
            Copy_Enabled = MFS_ENABLED
            Delete_Enabled = MFS_ENABLED
        Else
            Cut_Enabled = MFS_GRAYED
            Copy_Enabled = MFS_GRAYED
            Delete_Enabled = MFS_GRAYED
        End If
        
        ' Enable SelectAll menu item if there is any text in textbox
        If Len(oControl.Text) > 0 Then
            SelectAll_Enabled = MFS_ENABLED
        Else
            SelectAll_Enabled = MFS_GRAYED
        End If
        
        ' Get data from clipbaord
        oData.GetFromClipboard
        
        ' Following line generates an error if there
        ' is no text in clipboard
        testClipBoard = oData.GetText
    
    
        ' If NO error (ie there is text in clipboard) then
        ' enable Paste menu item. Otherwise, diable it.
        If Err.Number = 0 Then
            Paste_Enabled = MFS_ENABLED
        Else
            Paste_Enabled = MFS_GRAYED
        End If
        
        ' Clear the error object
        Err.Clear
        
        ' Clean up object references
        Set oControl = Nothing
        Set oData = Nothing
    
    
    End Sub
    
    
    Private Function GetSelection() As Long
    
    
        Dim menu_hwnd As Long
        Dim form_hwnd As Long
        Dim oMenuItemInfo1 As MENUITEMINFO
        Dim oMenuItemInfo2 As MENUITEMINFO
        Dim oMenuItemInfo3 As MENUITEMINFO
        Dim oMenuItemInfo4 As MENUITEMINFO
        Dim oMenuItemInfo5 As MENUITEMINFO
        Dim oMenuItemInfo6 As MENUITEMINFO
        Dim oRect As RECT
        Dim oPointAPI As POINTAPI
        
        ' Find hwnd of UserForm - note different classname
        ' Word 97 vs Word2000
        #If  VBA6 Then
            form_hwnd = FindWindow("ThunderDFrame", FormCaption)
        #Else 
            form_hwnd = FindWindow("ThunderXFrame", FormCaption)
        #End  If
    
    
        ' Get current cursor position
        ' Menu will be drawn at this location
        GetCursorPos oPointAPI
            
        ' Create new popup menu
        menu_hwnd = CreatePopupMenu
        
        ' Intitialize MenuItemInfo structures for the 6
        ' menu items to be added
        
        ' Cut
        With oMenuItemInfo1
                .cbSize = Len(oMenuItemInfo1)
                .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
                .fType = MFT_STRING
                .fState = Cut_Enabled
                .wID = ID_Cut
                .dwTypeData = "Cut"
                .cch = Len(.dwTypeData)
        End With
        
        ' Copy
        With oMenuItemInfo2
                .cbSize = Len(oMenuItemInfo2)
                .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
                .fType = MFT_STRING
                .fState = Copy_Enabled
                .wID = ID_Copy
                .dwTypeData = "Copy"
                .cch = Len(.dwTypeData)
        End With
        
        ' Paste
        With oMenuItemInfo3
                .cbSize = Len(oMenuItemInfo3)
                .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
                .fType = MFT_STRING
                .fState = Paste_Enabled
                .wID = ID_Paste
                .dwTypeData = "Paste"
                .cch = Len(.dwTypeData)
        End With
        
        ' Separator
        With oMenuItemInfo4
                .cbSize = Len(oMenuItemInfo4)
                .fMask = MIIM_TYPE
                .fType = MFT_SEPARATOR
        End With
        
        ' Delete
        With oMenuItemInfo5
                .cbSize = Len(oMenuItemInfo5)
                .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
                .fType = MFT_STRING
                .fState = Delete_Enabled
                .wID = ID_Delete
                .dwTypeData = "Delete"
                .cch = Len(.dwTypeData)
        End With
        
        ' SelectAll
        With oMenuItemInfo6
                .cbSize = Len(oMenuItemInfo6)
                .fMask = MIIM_STATE Or MIIM_ID Or MIIM_TYPE
                .fType = MFT_STRING
                .fState = SelectAll_Enabled
                .wID = ID_SelectAll
                .dwTypeData = "Select All"
                .cch = Len(.dwTypeData)
        End With
        
        ' Add the 6 menu items
        InsertMenuItem menu_hwnd, 1, True, oMenuItemInfo1
        InsertMenuItem menu_hwnd, 2, True, oMenuItemInfo2
        InsertMenuItem menu_hwnd, 3, True, oMenuItemInfo3
        InsertMenuItem menu_hwnd, 4, True, oMenuItemInfo4
        InsertMenuItem menu_hwnd, 5, True, oMenuItemInfo5
        InsertMenuItem menu_hwnd, 6, True, oMenuItemInfo6
        
        ' Return the ID of the item selected by the user
        ' and set it the return value of the function
        GetSelection = TrackPopupMenu _
                        (menu_hwnd, _
                         TPM_LEFTALIGN Or TPM_TOPALIGN Or TPM_RETURNCMD Or TPM_RIGHTBUTTON, _
                         oPointAPI.X, oPointAPI.Y, _
                         0, form_hwnd, oRect)
            
        ' Destroy the menu
        DestroyMenu menu_hwnd
    
    
    End Function
    Here is the user form code:

    Code:
    Private Sub frmNewApplicant_Initialize()
    
    End Sub
    
    
    Private Sub btnNewApplicantSubmit_Click()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    Dim tbl As ListObject
    Set tbl = ws.ListObjects("Onboarding")
    
    
        'Error Messages
        If tbOnbLastName.Value = vbNullString Then
            MsgBox "Enter Last Name"
            tbOnbLastName.SetFocus
            Cancel = False
        
        ElseIf tbOnbFirstName.Value = vbNullString Then
            MsgBox "Enter First Name"
            tbOnbFirstName.SetFocus
            Cancel = False
            
        ElseIf tbOnbEmail.Value = vbNullString Then
            MsgBox "Enter Email"
            tbOnbEmail.SetFocus
            Cancel = True
            
        ElseIf InStr(tbOnbEmail, "@") = 0 Then
            MsgBox "Invalid Email"
            tbOnbEmail.SetFocus
            Cancel = True
            
        ElseIf InStr(tbOnbEmail, ".") = 0 Then
            MsgBox "Invalid Email"
            tbOnbEmail.SetFocus
            Cancel = True
            
        ElseIf tbOnbPhone.Value = vbNullString Then
            MsgBox "Enter Phone Number"
            tbOnbPhone.SetFocus
            Cancel = True
            
        ElseIf Len(tbOnbPhone.Value) < 10 Or Len(tbOnbPhone.Value) > 10 Then
            MsgBox "Invalid Phone Number"
            tbOnbPhone.SetFocus
            Cancel = True
            
        ElseIf tbOnbZip.Value = vbNullString Then
            MsgBox "Enter Zip Code"
            tbOnbZip.SetFocus
            Cancel = True
            
        ElseIf Len(tbOnbZip.Value) < 5 Or Len(tbOnbZip.Value) > 6 Then
            MsgBox "Invalid Zip Code"
            tbOnbZip.SetFocus
            Cancel = True
            
        ElseIf cmbOnbSex.Value = vbNullString Then
            MsgBox "Enter Sex"
            cmbOnbSex.SetFocus
            Cancel = True
            
        ElseIf cmbOnbPosition.Value = vbNullString Then
            MsgBox "Enter Position"
            cmbOnbPosition.SetFocus
            Cancel = True
            
        ElseIf cmbOnbType.Value = vbNullString Then
            MsgBox "Enter Applicant Type"
            cmbOnbType.SetFocus
            Cancel = True
            
        ElseIf cmbOnbInternational.Value = vbNullString Then
            MsgBox "Enter International Status"
            cmbOnbInternational.SetFocus
            Cancel = True
            
        ElseIf IsDate(tbOnbDate.Value) = False And tbOnbDate.Value <> vbNullString And cmbOnbType = "Newcomer" Then
            MsgBox "Invalid Interview Date"
            tbOnbDate.SetFocus
            Cancel = True
            
        ElseIf IsDate(tbOnbDate.Value) = False And tbOnbDate.Value <> vbNullString And cmbOnbType = "Returner" Then
            MsgBox "Invalid Rehire Date"
            tbOnbDate.SetFocus
            Cancel = True
        'End Error Messages
            
        Else
            Dim newrow As ListRow
            Set newrow = tbl.ListRows.Add(1)
        'New row added to top row of 'Onboarding' table
    
    
        With newrow
            .Range(1, 2) = Me.tbOnbLastName
            .Range(1, 3) = Me.tbOnbFirstName
            .Range(1, 4) = Me.tbOnbEmail
            .Range(1, 5) = Me.tbOnbPhone * 1
            .Range(1, 6) = Me.tbOnbZip * 1
            .Range(1, 7) = Me.tbOnbPosition
            .Range(1, 8) = Me.cmbOnbType
            .Range(1, 9) = Me.cmbOnbInternational
            .Range(1, 10) = Me.tbOnbDate
            .Range(1, 11) = Me.tbOnbResultInput
            .Range(1, 20) = Me.tbOnbLost
            .Range(1, 25) = Me.cmbOnbSex
        End With
        'Populate new row with inputted values
    
    
        MacroOnbEmail           'Hyperlink inputted email
        MacroOnbAlphabetize     'Alphabetize the table following new row input
        Unload Me               'Close the userform
        End If
        
        If Sheets("Onboarding").Range("A16") = "2" And Sheets("Onboarding").Range("B16") = vbNullString And Sheets("Onboarding").Range("C16") = vbNullString Then
            MacroOnbDeleteTableRow
        End If
        'Deletes initial empty table row
    
    
        
    Application.Goto Sheets("Onboarding").Range("A1")    'Place cell cursor on cell A1
    ThisWorkbook.RefreshAll
    
    
    End Sub
    
    
    Private Sub btnNewApplicantSubmit_Enter()
    'Pressing the enter key will take the inputted userform data and translate it into readable data for the "Done (I)" and "Lost" columns
        If cmbOnbResult.Value = vbNullString Then       'Result textbox is blank
            tbOnbResultInput.Value = vbNullString       '"Done (I)" column is blank
            tbOnbLost.Value = vbNullString              '"Lost" column is blank
        ElseIf cmbOnbResult.Text = "Interview Not Yet Conducted" Then
            tbOnbResultInput.Text = vbNullString        '"Done (I)" column is blank
            tbOnbLost.Text = vbNullString               '"Lost" column is blank
        ElseIf cmbOnbResult.Text = "Hired" Then
            tbOnbResultInput.Text = "x"                 '"Done (I)" column is "x"
            tbOnbLost.Text = vbNullString               '"Lost" column is blank
        ElseIf cmbOnbResult.Text = "No Show" Then
            tbOnbResultInput.Text = vbNullString        '"Done (I)" column is blank
            tbOnbLost.Text = vbNullString               '"Lost column is blank
        ElseIf cmbOnbResult.Text = "Failed Interview" Then
            tbOnbResultInput.Text = "No"                '"Done (I)" column is "No"
            tbOnbLost.Text = "x"                        '"Lost" column is "x"
        End If
    
    
    End Sub
    
    
    Private Sub tbOnbLastName_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
        
        If Not Chr(KeyAscii) Like "[A-Z,a-z,---,., ,']" Then KeyAscii = 0       'Ony allows letters, dashes, periods, spaces and apostrophes
    
    
    End Sub
    
    
    Private Sub tbOnbLastName_Change()
        tbOnbLastName.Text = Replace(tbOnbLastName.Text, "..", ".")         'Does not allow repeating periods
        tbOnbLastName.Text = Replace(tbOnbLastName.Text, "''", "'")         'Does not allow repeating apostrophe
        tbOnbLastName.Text = Replace(tbOnbLastName.Text, "--", "-")         'Does not allow repeating dashes
        tbOnbLastName.Text = Replace(tbOnbLastName.Text, "  ", " ")         'Does not allow repeating spaces
        tbOnbLastName.Text = Replace(tbOnbLastName.Text, ",", "")           'Does not allow commas
    End Sub
    
    
    Private Sub tbOnbLastName_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    'Format Last Name textbox upon textbox exit
        tbOnbLastName.Value = Application.WorksheetFunction.Proper(tbOnbLastName.Value)   'Format with correct alphabetization
        tbOnbLastName.Value = Application.Trim(tbOnbLastName.Value)                       'Discard errant spaces and values
    End Sub
    
    
    Private Sub tbOnbFirstName_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
        
        If Not Chr(KeyAscii) Like "[A-Z,a-z,---,., ,']" Then KeyAscii = 0       'Ony allows letters, dashes, periods, spaces and apostrophes
    
    
    End Sub
    
    
    Private Sub tbOnbFirstName_Change()
        tbOnbFirstName.Text = Replace(tbOnbFirstName.Text, "..", ".")         'Does not allow repeating periods
        tbOnbFirstName.Text = Replace(tbOnbFirstName.Text, "''", "'")         'Does not allow repeating apostrophe
        tbOnbFirstName.Text = Replace(tbOnbFirstName.Text, "--", "-")         'Does not allow repeating dashes
        tbOnbFirstName.Text = Replace(tbOnbFirstName.Text, "  ", " ")         'Does not allow repeating spaces
        tbOnbFirstName.Text = Replace(tbOnbFirstName.Text, ",", "")           'Does not allow commas
    End Sub
    
    
    Private Sub tbOnbFirstName_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    'Format First name textbox upon textbox exit
        tbOnbFirstName.Value = Application.WorksheetFunction.Proper(tbOnbFirstName.Value) 'Format with correct alphabetization
        tbOnbFirstName.Value = Application.Trim(tbOnbFirstName.Value)                     'Discard errant spaces and values
    End Sub
    
    
    Private Sub tbOnbEmail_Change()
        tbOnbEmail.Text = LCase(tbOnbEmail.Text)              'Format with all lower case characters upon typing
        tbOnbEmail.Text = Replace(tbOnbEmail.Text, " ", "")   'Replace all spaces " " with null ""
    End Sub
    
    
    Private Sub tbOnbPhone_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
        Dim telnum As String, i As Integer, newtelnum As String
    'Format Phone textbox upon exit
        
        telnum = Trim(Me.tbOnbPhone.Value)         'Discard errant spaces and values
        For i = 1 To Len(telnum)
            If Mid(telnum, i, 1) Like "[0-9]" Then
                newtelnum = newtelnum & Mid(telnum, i, 1)
            End If
        Next i
        'Only allows for numeric values [0-9]. All others are discarded upon typing
    
    
        Me.tbOnbPhone.Value = newtelnum
    
    
    End Sub
    
    
    Private Sub tbOnbZip_BeforeUpdate(ByVal Cancel As MSForms.ReturnBoolean)
        Dim zip As String, i As Integer, newzip As String
    'Format Phone textbox upon exit
        
        zip = Trim(Me.tbOnbZip.Value)         'Discard errant spaces and values
        For i = 1 To Len(zip)
            If Mid(zip, i, 1) Like "[0-9]" Then
                newzip = newzip & Mid(zip, i, 1)
            End If
        Next i
        'Only allows for numeric values [0-9]. All others are discarded upon typing
    
    
        Me.tbOnbZip.Value = newzip
    
    
    End Sub
    
    
    Private Sub cmbOnbPosition_Exit(ByVal Cancel As MSForms.ReturnBoolean)
        If cmbOnbPosition.Text = "Sweep" Then
            tbOnbPosition.Text = "Sweep"
        ElseIf cmbOnbPosition.Text = "Truck" Then
            tbOnbPosition.Text = "Truck"
        ElseIf cmbOnbPosition.Text = "Restroom" Then
            tbOnbPosition.Text = "Restroom"
        ElseIf cmbOnbPosition.Text = "Supervisor" Then
            tbOnbPosition.Text = "Supervisor"
        ElseIf cmbOnbPosition.Text = "Area Supervisor" Then
            tbOnbPosition.Text = "Area Supervisor"
        ElseIf cmbOnbPosition.Text = "Morning Crew (Associate)" Then
            tbOnbPosition.Text = "Morning Crew"
        ElseIf cmbOnbPosition.Text = "Housekeeping (Associate)" Then
            tbOnbPosition.Text = "Housekeeping"
        End If
    End Sub
    
    
    Private Sub cmbOnbType_Click()
    'Dependent upon what Applicant Type value is selected, this determines what Hire labels are displayed
        If cmbOnbType.Text = "Newcomer" Then
            lbOnbDate.Visible = True
            lbOnbDate.Caption = "Interview Date"
            tbOnbDate.Visible = True
            lbOnbResult.Visible = True
            lbOnbResult.Caption = "Interview Result"
            cmbOnbResult.Visible = True
        ElseIf cmbOnbType.Text = "Returner" Then
            lbOnbDate.Visible = True
            lbOnbDate.Caption = "Rehire Date"
            tbOnbDate.Visible = True
            lbOnbResult.Visible = True
            lbOnbResult.Caption = "Rehire Result"
            cmbOnbResult.Visible = True
        End If
        
    End Sub
    
    
    Private Sub cmbOnbType_Exit(ByVal Cancel As MSForms.ReturnBoolean)
    'Dependent upon what Applicant Type value is selected, this determines what Hire labels are displayed
        If cmbOnbType.Text = "Newcomer" Then
            lbOnbDate.Visible = True
            lbOnbDate.Caption = "Interview Date"
            tbOnbDate.Visible = True
            lbOnbResult.Visible = True
            lbOnbResult.Caption = "Interview Result"
            cmbOnbResult.Visible = True
        ElseIf cmbOnbType.Text = "Returner" Then
            lbOnbDate.Visible = True
            lbOnbDate.Caption = "Rehire Date"
            tbOnbDate.Visible = True
            lbOnbResult.Visible = True
            lbOnbResult.Caption = "Rehire Result"
            cmbOnbResult.Visible = True
        End If
    
    
    End Sub
    
    
    Private Sub tbOnbDate_Enter()
    'When the user enters the Date textbox, it resets the Result combobox
        cmbOnbResult.Value = vbNullString
    End Sub
    
    
    Private Sub tbOnbDate_MouseUp(ByVal Button As Integer, ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    'When the user clicks the Date textbox, it resets the Result combobox
        cmbOnbResult.Value = vbNullString
    End Sub
    
    
    Private Sub tbOnbDate_Change()
    Dim idate As String, i As Integer, newidate As String
    'Format Date textbox upon typing
    
    
        tbOnbDate.MaxLength = 10                                'Maximum of 10 characters in the textbox
        tbOnbDate.Text = Replace(tbOnbDate.Text, "-", "/")      'Replace all dash "-" characters with slashes "/"
        tbOnbDate.Text = Replace(tbOnbDate.Text, ".", "/")      'Replace all period "." characters with slashes "/"
        tbOnbDate.Text = Replace(tbOnbDate.Text, "//", "/")     'Replace all back to back slashes "//" with solo slashes "/"
    
    
        idate = Trim(Me.tbOnbDate.Value)      'Discard errant spaces and values
    
    
        For i = 1 To Len(idate)
        If Mid(idate, i, 1) Like "[0-9]" Then
            newidate = newidate & Mid(idate, i, 1)
        'Only allows for numeric values [0-9]. All others are discarded upon typing
        ElseIf Mid(idate, i, 1) Like "/" Then
            newidate = newidate & Mid(idate, i, 1)
        'Only allows for slashes "/". All others are discarded upon typing
        End If
        Next i
    
    
        Me.tbOnbDate.Value = newidate
      
    End Sub
    
    
    Private Sub tbOnbDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
        tbOnbDate.Text = Format(tbOnbDate.Value, "m/d/yyyy")        'Format Date textbox in short date format upon exit
    End Sub
    
    
    Private Sub cmbOnbResult_Enter()
        If IsDate(tbOnbDate.Value) = False And tbOnbDate.Value <> vbNullString And cmbOnbType = "Newcomer" Then
            MsgBox "Invalid Interview Date"
            tbOnbDate.SetFocus
            Cancel = True
        ElseIf IsDate(tbOnbDate.Value) = False And tbOnbDate.Value <> vbNullString And cmbOnbType = "Returner" Then
            MsgBox "Invalid Rehire Date"
            tbOnbDate.SetFocus
            Cancel = True
        'If the string in the Date textbox is not a valid date format, it will return a messagebox rather than an error
    
    
        ElseIf tbOnbDate.Text = vbNullString Then
            cmbOnbResult.RowSource = "Result_Blank"
        ElseIf CDate(tbOnbDate.Text) > Date Then
            cmbOnbResult.RowSource = "Result_Blank"
        ElseIf CDate(tbOnbDate.Text) < Date Then
            cmbOnbResult.RowSource = "Result_Day_Past"
        ElseIf CDate(tbOnbDate.Text) = Date Then
            cmbOnbResult.RowSource = "Result_Day_Of"
        'The inputted date determines what options are available in the Result combobox
        End If
    End Sub
    
    
    Private Sub tbOnbLastName_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    
         If Button = 2 Then     'If textbox is right clicked
             Call ShowPopup(Me, Me.Caption, X, Y)
         End If
         'Opens right click menu
    
    
    End Sub
    
    
    Private Sub tbOnbFirstName_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    
         If Button = 2 Then     'If textbox is right clicked
             Call ShowPopup(Me, Me.Caption, X, Y)
         End If
         'Opens right click menu
    
    
    End Sub
    
    
    Private Sub tbOnbEmail_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    
         If Button = 2 Then     'If textbox is right clicked
             Call ShowPopup(Me, Me.Caption, X, Y)
         End If
         'Opens right click menu
    
    
    End Sub
    
    
    Private Sub tbOnbPhone_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    
         If Button = 2 Then     'If textbox is right clicked
             Call ShowPopup(Me, Me.Caption, X, Y)
         End If
         'Opens right click menu
    
    
    End Sub
    
    
    Private Sub tbOnbZip_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    
         If Button = 2 Then     'If textbox is right clicked
             Call ShowPopup(Me, Me.Caption, X, Y)
         End If
         'Opens right click menu
    
    
    End Sub
    
    
    Private Sub tbOnbDate_MouseDown(ByVal Button As Integer, _
       ByVal Shift As Integer, ByVal X As Single, ByVal Y As Single)
    
    
         If Button = 2 Then     'If textbox is right clicked
             Call ShowPopup(Me, Me.Caption, X, Y)
         End If
         'Opens right click menu
    
    
    End Sub
    I no longer receive errors, but the context menu will not display

  2. #2
    Board Regular
    Join Date
    Dec 2015
    Posts
    62
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: 64 Bit 2016 Right Click Context Menu (User Form)

    I apologize for spam, but can the above code be modified to work with the 64 bit 2016 Excel, or will new code be needed?

    Thanks

  3. #3
    MrExcel MVP
    Join Date
    May 2003
    Location
    USA
    Posts
    4,672
    Post Thanks / Like
    Mentioned
    5 Post(s)
    Tagged
    1 Thread(s)

    Default Re: 64 Bit 2016 Right Click Context Menu (User Form)

    Not an expert on API calls, but I think that some of the Longs in the declarations should be LongPtr or LongLong.

    When I have to convert to 64-bit, I usually just google for the API name and PtrSafe. For example, if you search for "CreatePopupMenu PtrSafe", you may even find a 64-bit version of this whole sequence of code.
    Jon Peltier
    Peltier Technical Services, Inc.
    Try Peltier Tech Charts for Excel

  4. #4
    Board Regular
    Join Date
    Dec 2015
    Posts
    62
    Post Thanks / Like
    Mentioned
    0 Post(s)
    Tagged
    0 Thread(s)

    Default Re: 64 Bit 2016 Right Click Context Menu (User Form)

    Thanks, I will give this a shot.

  5. #5
    Board Regular Jaafar Tribak's Avatar
    Join Date
    Dec 2002
    Location
    Larache--Morocco
    Posts
    7,347
    Post Thanks / Like
    Mentioned
    39 Post(s)
    Tagged
    3 Thread(s)

    Default Re: 64 Bit 2016 Right Click Context Menu (User Form)

    Quote Originally Posted by CokeOrCrack View Post
    I apologize for spam, but can the above code be modified to work with the 64 bit 2016 Excel, or will new code be needed?

    Thanks
    The vba you posted is quite long and the userform has various controls in it so it is cumbersome to go through the entire code.

    If you can upload a copy of the workbook to some file shaing site and post a link here, I can take a look .

    Regards.
    Office/Excel 2010 64Bits -- Win10 64Bits

    Common sense is not so common.


    http://photo-larache.blogspot.com/

Some videos you may like

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •