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:
Here is the user form code:
I no longer receive errors, but the context menu will not display
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 FunctionHere 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 SubI no longer receive errors, but the context menu will not display
