I am simply trying to create two variables in TempVars. Here is the relevant code:
Private Sub cboFilterFavorites_AfterUpdate()
On Error GoTo ApplyFilterFavorites_Err
If (IsNull(Me.cboFilterFavorites) Or Me.cboFilterFavorites = 0) Then
ClearFilter
Exit Sub
End If
If (Me.cboFilterFavorites = -1) Then
ManageFilters
Exit Sub
End If
' Apply Filters
TempVars.Add "FilterString", DLookup("[FilterString]", "T_Filter", "ID = " & Me.cboFilterFavorites)
TempVars.Add "SortString", DLookup("[SortString]", "T_Filter", "ID = " & Me.cboFilterFavorites)
With Me.Form
If (Not IsNull(TempVars!FilterString)) Then
.Filter = TempVars!FilterString
If Not .FilterOn Then
.FilterOn = True
End If
End If
If (Not IsNull(TempVars!SortString)) Then
.OrderBy = Nz(TempVars!SortString)
If Not .OrderByOn Then
.OrderByOn = Not IsNull(TempVars!SortString)
End If
End If
End With
TempVars.Remove "FilterString"
TempVars.Remove "SortString"
ApplyFilterFavorites_Exit:
Exit Sub
ApplyFilterFavorites_Err:
MsgBox Error$
Resume ApplyFilterFavorites_Exit
End Sub
Public Function ManageFilters() 'Opens the filter form.
On Error GoTo ManageFilters_Err
TempVars.Add "ObjectType", Application.CurrentObjectType
Debug.Print TempVars!ObjectType
TempVars.Add "ObjectName", Application.CurrentObjectName
Debug.Print TempVars!ObjectName
DoCmd.OpenForm "frmFilter", acNormal, "", "[ObjectName]=[TempVars]![ObjectName]", , acDialog
Me.Refresh
TempVars.Remove "ObjectType"
TempVars.Remove "ObjectName"
ManageFilters_Exit:
Exit Function
ManageFilters_Err:
MsgBox Error$
Resume ManageFilters_Exit
End Function
The weird thing is if I put a stop at the beginning of the event and step through the code it works. But if I run it as normal it does not (meaning [TempVars]![ObjectType] = -1; [TempVars]![ObjectName] = blank)
Here is what Microsoft says on the method. Any ideas?
Related
I have some VBA code that checks a person's job title before allowing someone to edit the document. After adding this code in I occasionally get an "Automation Error Catastrophic Failure" message only when opening the spreadsheet. As far as I can tell it does not damage any part of the workbook, and you just have to exit the command debugger twice before it opens. Obviously others at work see this message and overreact to it. Please see my functions that activate when opening the workbook.
Private Sub Workbook_Open()
Sheets("Start Here").Select
Range("A3").Select
End Sub
Private Sub Worksheet_Activate()
If Usercheck() = True Then
ProtectionOff
Else
ProtectionOff
Range("A1:V260").Locked = True
ProtectionOn
End If
End Sub
Function Usercheck() As Boolean
Dim user As String
Dim title As String
On Error GoTo ErrorHandler
user = UserName()
title = WorksheetFunction.VLookup(user,
Sheets("BaseTables").Range("tblStaff[[#All],[Username]:[Title1]]"), 2, False)
If Left(title, 20) = "Technical Specialist" Then
Usercheck = True
ElseIf Left(title, 19) = "Engineering Manager" Then
Usercheck = True
ElseIf Left(title, 9) = "Team Lead" Then
Usercheck = True
Else
Usercheck = False
End If
Exit Function
ErrorHandler:
Usercheck = False
End Function
Public Function UserName()
UserName = Environ$("UserName")
End Function
I have use "E "0000000000a;0;# in input mask and included this code to check if the employeeCode already exists in the Before Update.
But when i am trying to input a duplicate employee code. It's allowing it.
Any idea?
Private Sub Empl_Code_BeforeUpdate(Cancel As Integer)
If IsNull(DLookup("[EmplCode]", _
"FORM EMPLOYEE", _
"[EmplCode] = """ & Me.Empl_Code.Text & """")) = False Then
Cancel = True
MsgBox "Record already exists", vbOKOnly, "Warning"
Me![Empl Code].Undo
End If
End Sub
Your code looks legit.
Test your IsNull(DLookup... expression in Immediate window (View - Immediate window in VBA Editor) when you are trying to input a duplicate code.
Also you can shorten a bit your expression with DCount like that:
Private Sub Empl_Code_BeforeUpdate(Cancel As Integer)
If DCount("*", _
"FORM EMPLOYEE", _
"[EmplCode] = """ & Me.Empl_Code.Text & """") > 0 Then
Cancel = True
MsgBox "Record already exists", vbOKOnly, "Warning"
Me![Empl Code].Undo
else
' Just for test
MsgBox "Value: " & Me.Empl_Code.Text
End If
End Sub
I have a textbox that dynamically filters a listbox on the same form as you type. The listbox filters perfectly, but the selected value is not saving correctly. For example, if you click on the fourth value after filtering the listbox and then close the form, it actually saves what would have been the fourth value had the list not been filtered.
Here is the code:
Private Sub txtSearch_Change()
'CODE THAT HANDLES WHAT HAPPENS WHEN THE USER TYPES IN THE SEARCH BOX
Dim strFullList As String
Dim strFilteredList As String
If blnSpace = False Then
Me.Refresh 'refresh to make sure the text box changes are actually available to use
'specify the default/full rowsource for the control
strFullList = "SELECT [Project ID], [Project Name] FROM [Admin: Projects] ORDER BY [Project Name];"
'specify the way you want the rowsource to be filtered based on the user's entry
strFilteredList = "SELECT [Project ID], [Project Name] FROM [Admin: Projects] WHERE [Project Name] LIKE ""*" & Me.txtSearch.Value & "*"" ORDER BY [Project Name]"
'run the search
fLiveSearch Me.txtSearch, Me.lstItems, strFullList, strFilteredList, Me.txtCount
End If
End Sub
Private Sub txtSearch_KeyPress(KeyAscii As Integer)
'NECESSARY TO IDENTIFY IF THE USER IS HITTING THE SPACEBAR
'IN WHICH CASE WE WANT TO IGNORE THE INPUT
On Error GoTo err_handle
If KeyAscii = 32 Then
blnSpace = True
Else
blnSpace = False
End If
Exit Sub
err_handle:
Select Case Err.Number
Case Else
MsgBox "An unexpected error has occurred: " & vbCrLf & Err.Description & _
vbCrLf & "Error " & Err.Number & "(" & Erl & ")"
End Select
End Sub
Private Sub txtSearch_GotFocus()
' USED TO REMOVE THE PROMPT IF THE CONTROL GETS FOCUS
On Error Resume Next
If Me.txtSearch.Value = "(type to search)" Then
Me.txtSearch.Value = ""
End If
End Sub
Private Sub txtSearch_LostFocus()
' USED TO ADD THE PROMPT BACK IN IF THE CONTROL LOSES FOCUS
On Error Resume Next
If Me.txtSearch.Value = "" Then
Me.txtSearch.Value = "(type to search)"
End If
End Sub
Private Sub Form_Close()
DoCmd.SetWarnings False
End Sub
I've inherited this database and am trying to fix up areas that are not working. I'm definitely a novice and I can't seem to figure out where the error might be in the code that is causing the wrong value to save to the record. Any guidance would be appreciated.
Replace:
'run the search
fLiveSearch Me.txtSearch, Me.lstItems, strFullList, strFilteredList, Me.txtCount
With
me.lstitems.rowsourcetype = "Table/Query"
me.lstitems.rowsource = strfilteredlist
What I'd like to accomplish:
Do While ctr < List and Break = False
code that works here...
DoEvents
If KeyDown = vbKeyQ
Break = True
End If
loop
Break out of a loop by holding down a key (eg, Q). I've read up on DoEvents during the loop in order to achieve the functionality that I want. The idea is to have a Do While loop run until either the end of the list is reached or when Q is held down. I'm having issues getting the code to work the way I want, so I'm reaching out to hopefully end the frustration. My experience with VBA is very limited.
UPDATE - More code to expose where the problem might be. This is all in the order I have it (in case order of subs makes a difference:
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim strChar As String
strChar = UCase(Chr(KeyAscii))
If strChar = "Q" Then
blnQuit = True
Debug.Print "Q pressed"
End If
End Sub
Private Sub Master_Report_Click()
Dim i As Integer
Dim Deptarray
blnQuit= False
If IsNull(Me.Hospital) Then
MsgBox ("Please Choose a Hospital")
Else
DoCmd.OpenForm "Report Print/Update", acNormal, , , , acDialog
If Report_choice = "Current_List" Then
Debug.Print "Create master rec report"
DoCmd.OpenReport "Master Rec Report", acViewPreview
DoCmd.RunCommand acCmdZoom100
ElseIf Report_choice = "Update_All" Then
total = (DCM_Dept.ListCount - 1)
ctr = 1
Do While ctr < (DCM_Dept.ListCount) And LoopBreak = False
Debug.Print "LoopBreak: "; LoopBreak
Debug.Print "Counter: "; ctr
DCM_Dept.Value = DCM_Dept.Column(0, ctr)
Update_Site (Me.Hospital)
ctr = ctr + 1
'DoEvents
' If vbKeyQ = True Then
'LoopBreak = True
'End If
Loop
Debug.Print "Update loop exited"
Debug.Print "Create master rec report"
DoCmd.OpenReport "Master Rec Report", acViewPreview
DoCmd.RunCommand acCmdZoom100
Else
End If
End If
End Sub
Private Sub Update_Site(Site As String)
If IsNull(Me.Hospital) Then
MsgBox ("Please Choose a Hospital")
ElseIf IsNull(Me.DCM_Dept) Then
MsgBox ("Please Choose a Department")
ElseIf Site = "FORES" Then
Debug.Print "Run FORES update macro"
DoCmd.RunMacro "0 FORES Master Add/Update"
ElseIf Site = "SSIUH" Then
Debug.Print "Run SSIUH update macro"
DoCmd.RunMacro "0 SSIUH Master Add/Update"
End If
End Sub
Report_choice and LoopBreak are both Public variables. My original idea was to have a popup form floating over the main form to display a counter ("Processing department X of Y") and a button to break the loop on there. I realized that the form was unresponsive while the Update_Site() was running its macro so I decided to go with holding a key down instead.
So, where do I go from here to get OnKeyDown to work? Or, is there a better way to do it?
Try to set the Key Preview of the form to Yes and add a variable blnQuit and a key press event in your form like this:
Private blnQuit As Boolean
'form
Private Sub Form_KeyPress(KeyAscii As Integer)
Dim strChar As String
strChar = UCase(Chr(KeyAscii))
If strChar = "Q" Then
blnQuit = True
End If
End Sub
Then check the blnQuit in your Do While condition, like this:
blnQuit = False
Do While ctr < List And Not blnQuit
code that works here...
DoEvents
loop
I try to improve a report I made to document databases, by adding a VBA line count to Modules and Forms. The following code works perfectly in a standard module:
Sub test()
Dim accObj As AccessObject, bwasOpen As Boolean, objName As String
objName = "Form1"
Set accObj = CurrentProject.AllForms(objName)
bwasOpen = accObj.IsLoaded
If Not bwasOpen Then
DoCmd.OpenForm objName, acDesign, WindowMode:=acHidden
End If
If Forms(objName).HasModule Then
DoCmd.OpenModule "Form_" & objName
Debug.Print Modules("Form_" & objName).CountOfLines
End If
If Not bwasOpen Then
DoCmd.Close acForm, objName, acSaveNo
End If
End Sub
But when I use a similar code in the report itself, I have an error. And since that error is happening in the class module (the report), I feel a bit stuck with debugging. The code in the report:
Set accObj = CurrentProject.AllForms(objName)
bwasOpen = accObj.IsLoaded
If Not bwasOpen Then
DoCmd.OpenForm objName, acDesign, WindowMode:=acHidden 'Breaks here
End If
If Forms(objName).HasModule Then
DoCmd.OpenModule "Form_" & objName
GetExtraInfo = Modules("Form_" & objName).CountOfLines
End If
If Not bwasOpen Then
DoCmd.Close acForm, objName, acSaveNo
End If
The code is called from a report control using =GetExtraInfo(). The whole thing works well, except this new part where I want to return the CountOfLines for Forms.
Update: I have added some error trapping, and it gives error:
2486 - You can't carry out this action at the present time
The whole db can be downloaded here, its's only 300 KB. The report is named "rptObjList".
The "bad" code has been commented out. It is an Access 2003 db.
Thanks for your help.
Your code opens a form and checks its .HasModule property. And if the form has a module, you open that module to check .CountOfLines. However, you need not open the module to determine its .CountOfLines. And I would try to avoid opening the form, too.
? VBE.ActiveVBProject.VBComponents("Form_Form1").CodeModule.CountOfLines
6
If you ask for .CountOfLines for a module which doesn't exist, such as the following, you can trap error #9 ('Subscript out of range') to give you an alternative to checking the .HasModule property:
? VBE.ActiveVBProject.VBComponents("bogus").CodeModule.CountOfLines
Or you could check for the code module with a function similar to minimally tested ModuleExists() outlined below.
Note I'm unsure how helpful my suggestions will be because I struggled to follow your code. Furthermore I unwisely chose to step through the code behind rptObjList and became frustrated by all the unhandled errors when it calls GetDesc() for objects which have no Description property. I just gave up.
Public Function ModuleExists(ByVal pModule As String, _
Optional ByVal pProject As String = "") As Boolean
Dim blnReturn As Boolean
Dim objVBProject As Object
Dim strMsg As String
On Error GoTo ErrorHandler
If Len(pProject) = 0 Then
Set objVBProject = VBE.ActiveVBProject
Else
Set objVBProject = VBE.VBProjects(pProject)
End If
blnReturn = Len(objVBProject.VBComponents(pModule).Name) > 0
ExitHere:
Set objVBProject = Nothing
ModuleExists = blnReturn
Exit Function
ErrorHandler:
Select Case Err.Number
Case 9 ' Subscript out of range
' no such module; function returns False
Case Else
strMsg = "Error " & Err.Number & " (" & Err.Description _
& ") in procedure ModuleExists"
MsgBox strMsg
End Select
GoTo ExitHere
End Function