64 Bit 2016 Right Click Context Menu (User Form)

CokeOrCrack

Board Regular
Joined
Dec 13, 2015
Messages
81
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
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=If]#If[/URL]  VBA6 Then
        form_hwnd = FindWindow("ThunderDFrame", FormCaption)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=Else]#Else[/URL] 
        form_hwnd = FindWindow("ThunderXFrame", FormCaption)
    [URL=https://www.mrexcel.com/forum/usertag.php?do=list&action=hash&hash=End]#End[/URL]  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
 

Excel Facts

Excel Can Read to You
Customize Quick Access Toolbar. From All Commands, add Speak Cells or Speak Cells on Enter to QAT. Select cells. Press Speak Cells.
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0

Forum statistics

Threads
1,213,538
Messages
6,114,218
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top