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
Related
I have a database with the following
Mainfrm Form (Main Form - it has popup messages on load event)
kikThemOut Form (Loads hidden with Main Form and every 5 sec it checks for field value on table if it is 1 then call the Function fGetOut())
GetOutMod Module (has fGetOut() Function)
it works all fine, except when application closing it loads the popup alerts from Mainfrm again! which should not load.
Mainfrm Form Code
Private Sub Form_Load()
'to check for T&I notifications
Dim trs As Recordset
Set trs = CurrentDb.OpenRecordset("Y22_CurrMonth")
If trs.EOF = False Then
Dim tMsg, tStyle, tTitle, tHelp, tCtxt, tResponse, tMyString
tMsg = "There are Notifications Due, Do you want to view them?"
tStyle = vbYesNo + vbExclamation + vbDefaultButton2
tTitle = "Notifications Alert"
tHelp = "DEMO.HLP"
tCtxt = 1000
tResponse = MsgBox(tMsg, tStyle, tTitle, tHelp, tCtxt)
If tResponse = vbYes Then ' User chose Yes.
DoCmd.OpenReport "Notifications Current Month", acViewReport, acWindowNormal
Else
tMyString = "No"
End If
End If
'to load the checker form
DoCmd.OpenForm "kikThemOut", , , , , acHidden
End Sub
and this is the GetOutMod Module to force users to exit the db
GetOutMod Module
Option Compare Database
Option Explicit
Function fGetOut() As Integer
Dim RetVal As Integer
Dim db As DAO.Database
Dim rst As Recordset
On Error GoTo Err_fGGO
Set db = DBEngine.Workspaces(0).Databases(0)
Set rst = db.OpenRecordset("KickEmOff", dbOpenSnapshot)
If rst.EOF And rst.BOF Then
RetVal = True
GoTo Exit_fGGO
Else
If DSum("GetOut", "KickEmOff") = "1" Then
Application.Quit
Else
RetVal = True
End If
End If
Exit_fGGO:
fGetOut = RetVal
Exit Function
Err_fGGO:
'Note lack of message box on error
Resume Next
End Function
And this code in the load event of kikThemOut form to check for the same condition, if it is 1 then load this popup message (I could not add popup message to my GetOutMod Module with the function fGetOut)
kikThemOut form Code
Private Sub Form_Timer()
If DSum("GetOut", "KickEmOff") = "1" Then
Set TaskDialogAC = New cTaskDialog
With TaskDialogAC
.Init
.MainInstruction = "Dashboard Maintenance"
.Flags = TDF_CALLBACK_TIMER
.Content = "The Dashboard will be closed after 20 seconds for maintenance"
.CommonButtons = TDCBF_CLOSE_BUTTON
.IconMain = IDI_WINLOGO
.Footer = "Closing in 20 seconds..."
.Title = "Dashboard Maintenance"
.AutocloseTime = 20 'seconds
.ParenthWnd = Me.hwnd
.ShowDialog
End With
Call fGetOut
Else
If DSum("GetOut", "KickEmOff") = "0" Then
DoCmd.Requery
End If
End If
End Sub
Really hard to read your code and figure out where your function is being called from.
But I'm assuming this should work for you as described
Add this before your fGetOut function
Public blClosing as Boolean
And then add this inside your function at the top (after On Error GoTo Err_fGGO)
if blClosing then
blClosing = False
Exit function
Else
blClosing = True
End if
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?
The Listbox: SearchList get data from the query: Machine_Search.So how it works is i input my Serial Number into the Search textbox and press the button search then select the record displayed on the SearchList. When the record is selected, i then press edit. The condition is that if the record that i search using Serial Number have empty field in the End_Date it will go on smoothly. However if the record that is search using Serial Number have a date in the End_Date it will prompt a msgbox and, close and open the form again. The issue lies at where it cannot detect if End_Date is null or empty and will prompt the msgbox regardless of the condition.
Table: Machine
Query: Machine_Search - It query the table:Machine where there is a form called: Machine_Load which fills half the field in the table and the other will be filled by Machine_Unload/
Form:Machine_Unload
Is there a way to solve this issue?
Private Sub cmdSearch_Click()
Dim check As String
DoCmd.OpenQuery "Machine_Search"
DoCmd.Close acQuery, "Machine_Search"
SearchList.Requery
If SearchList.ListCount = 0 Then
MsgBox ("No records found.")
DoCmd.Close
DoCmd.OpenForm "Machine_Unload"
Exit Sub
End If
Me.cmdEdit.Enabled = True
Me.cmdSearch.Enabled = False
Me.txtSN.Enabled = True
Me.txtDate.Enabled = True
Me.txtTime.Enabled = True
Me.CheckTime.Enabled = True
Me.ListSuccess.Enabled = True
Me.txtOperator.Enabled = True
Me.txtRemarks.Enabled = True
Me.txtSearch.Enabled = False
Me.txtSN.SetFocus
End Sub
Private Sub cmdEdit_Click()
On Error GoTo Err_cmdEdit_Click
Dim SN_Value As String
Dim Date_Value As String
If Me.SearchList.ListIndex > -1 Then
SN_Value = Me.SearchList.Value
Date_Value = Me.SearchList.Column(5)
If Not IsEmpty(Date_Value) Then
MsgBox ("The Unload data for this Serial Number have been filled, Please confirm with cell leader.")
DoCmd.Close
DoCmd.OpenForm "Esagon_Unload"
Exit Sub
End If
End If
'check whether there exists data in list
If Not (Me.SearchList.Recordset.EOF And Me.SearchList.Recordset.BOF) Then
'get data to text box control
With Me.SearchList.Recordset
Me.txtSN = .Fields("Serial_Number")
'store id of serial number in tag of txtSN in case id is modified
Me.txtSN.Tag = .Fields("Serial_Number")
'Disable button edit
Me.cmdEdit.Enabled = False
Me.cmdUpdate.Enabled = True
End With
End If
End_Err:
Exit Sub
Err_cmdEdit_Click:
MsgBox ("Select the Serial Number." & vbCrLf & "Please try again and click on the Serial Number below.")
DoCmd.Close
DoCmd.OpenForm "Machine_Unload"
Resume End_Err
End Sub
SELECT Machine.Serial_Number, Machine.End_Date, Machine.End_Time, Machine.End_System_Time, Machine.End_Operator, Machine.Success, Machine.End_Remarks
FROM Machine
WHERE (((Machine.Serial_Number)=[Forms]![Machine_Unload]![txtSearch]));
IsEmpty is not for this usage. Try:
If Not IsNull(Date_Value) Then
or:
If Nz(Date_Value) <> "" Then
I have two forms frmProductCreate and frmColourCreate.
In frmProductCreate I have:
Combobox: colourID
Button: btnColCreate
The idea is that if a user needs to create a new colour, they can click on the create button which opens frmColourCreate, name the new colour and click save button. Which will save the new colour in the colours table (which is the record source for the cbo ColourID in frmProductCreate). Then requery colourID in frmProductCreate and close frmColourCreate.
What I also want this save button to do is after the requery to select the cbo colourID and go to the last created colour. i.e. the last record. I have tried a few codes but failed to make it work. Any help will be greatly appreciated.
Private Sub btnSavecol_Click()
Dim cancel As Integer
If Me.ColName = "" Then
MsgBox "You must enter a Colour Name."
DoCmd.GoToControl "ColName"
cancel = True
Else
If MsgBox("Are you sure you want to create new Colour?", vbYesNo) = vbNo Then
cancel = True
Else
CurrentDb.Execute " INSERT INTO Colours (ColName) VALUES ('" & Me.ColName & "')"
Me.ColName = ""
DoCmd.Close
If CurrentProject.AllForms("frmProductCreate").IsLoaded = False Then
cancel = True
Else
Forms!frmproductCreate!ColourID.Requery
'Forms!frmproductCreate!ColourID.SetFocus
'Forms!frmproductCreate!ColourID.items.Count = -1
'Forms!frmproductCreate!ColourID.Selected(Forms!frmproductCreate!ColourID.Count - 1) = False
'YourListBox.SetFocus
'YourListBox.ListIndex = YourListBox.ListCount - 1
'YourListBox.Selected(YourListBox.ListCount - 1) = False
End If
If CurrentProject.AllForms("frmProductDetails").IsLoaded = False Then
cancel = True
Else
Forms!frmproductDetails!ColourID.Requery
End If
End If
End If
End Sub
Some remarks:
Whatfor is the variable cancel? Because it is not used, I removed it.
I have no really idea whatfor you need Me.ColName = "".
Why do you close the current form so early? I moved DoCmd.Close to the end.
I made your code a bit more readable, by removing 'arrow-code' (those nested IFs).
Finally try this:
Private Sub btnSavecol_Click()
If Me.ColName.Value = "" Then
MsgBox "You must enter a Colour Name."
DoCmd.GoToControl "ColName"
Exit Sub
End If
If MsgBox("Are you sure you want to create new Colour?", vbYesNo) = vbNo Then Exit Sub
CurrentDb.Execute "INSERT INTO Colours (ColName) VALUES ('" & Me.ColName.Value & "')"
If Not CurrentProject.AllForms("frmProductCreate").IsLoaded Then GoTo Done
Forms!frmproductCreate!ColourID.Requery
'This sets the ComboBox 'ColourID' to the new colour:
'Forms!frmproductCreate!ColourID.Value = Me.ColName.Value
'If you use an automatic generated ID in the table 'Colours', then you will have to get that ID from the color and set it to the ComboBox:
Forms!frmproductCreate!ColourID.Value = DLookup("ColID", "Colours", "ColName = '" & Me.ColName.Value & "'")
Me.ColName.Value = ""
If Not CurrentProject.AllForms("frmProductDetails").IsLoaded Then GoTo Done
Forms!frmproductDetails!ColourID.Requery
Done:
DoCmd.Close
End Sub
I have a Problem with my Userform. It should automatically Switch to another TextBox when an selection in the catpart made. I get the Automation Error: It is illegal to call out while inside message filter.
Run-time error '-2147418107 (80010005)
Sub Auswahl_Click()
Dim sel As Object, Objekt As Object, ObjektTyp(0)
Dim b, Auswahl, i As Integer
ObjektTyp(0) = "Body"
Set sel = CATIA.ActiveDocument.Selection
For i = 1 To 6
sel.Clear
UserFormNow.Controls("Textbox" & i).SetFocus
Auswahl = sel.SelectElement2(ObjektTyp, "Wähle ein Body aus...", False)
Set b = CATIA.ActiveDocument.Selection.Item(i)
If Auswahl = "Normal" Then
Set Objekt = sel.Item(i)
UserFormNow.ActiveControl = Objekt.Value.Name
sel.Clear
End If
i = i + 1
Next
sel.Clear
End Sub
' EXCEL DATEI ÖFFNEN____________________________________
Sub Durchsuchen1_Click()
Dim FPath As String
FPath = CATIA.FileSelectionBox("Select the Excel file you wish to put the value in", "*.xlsx", CatFileSelectionModeOpen)
If FPath = "" Then
Else
DurchsuchenFeld.AddItem FPath
ListBox1.Clear
ListBox1.AddItem "Bitte wählen Sie das Panel"
TextBox1.SetFocus
End If
End Sub
' FORMULAR SCHLIEßEN____________________________________
Sub ButtonEnd_Click()
ButtonEnd = True
Unload UserFormNow
End Sub
First you have to know that when you use an UI and still want to interact with CATIA, you have to choices:
Launch the UI in NoModal: mode UserFormNow.Show 0
Hide the UI each time you want to interact with CATIA: Me.Hide or UserFormNow.Hide
Then, I strongly recommend you to avoid looking for items with names:
UserFormNow.Controls("Textbox" & i).SetFocus
If you want to group controls and loop through them, use a Frame and then use a For Each loop.
For Each currentTextBox In MyFrame.Controls
MsgBox currentTextBox.Text
Next
Regarding your code, many simplifications can be done:
Private Sub Auswahl_Click()
Dim sel As Object
Dim currentTextBox As TextBox
Dim Filter As Variant
ReDim Filter(0)
Filter(0) = "Body"
Set sel = CATIA.ActiveDocument.Selection
'Loop through each textbox
For Each currentTextBox In MyFrame.Controls
sel.Clear
'Ask for the selection and test the result at the same time
If sel.SelectElement2(Filter, "Wahle ein Body aus...", False) = "Normal" Then
'Get the name without saving the object
currentTextBox.Text = sel.Item2(1).Value.Name
Else
'allow the user to exit all the process if press Escape
Exit Sub
End If
Next
sel.Clear
End Sub