Gillian Bennett
asked on
Run-time error '3265' Item cannot be found in the collection to the requested name or ordinal
Everytime I try opening the MS Access file, I receive the error mentioned in the title. Then, when I click the debug option, the following script comes up in the main code window, where "rstTablesADO.Find strField & " = " & LookFor" is highlighted:
"Option Explicit
Public Const blnMaintenance As Boolean = False
Public Const blnSquadron As Boolean = False
Public Const lngCurrentDayColor As Integer = 36
Public Const strBackUpDatabaseFile As String = "Blank Database.mdb"
Public Const strBackupDirectory As String = "JAMMIE Backup"
Public Const strDatabaseFileName As String = "JAMMIE Database.mdb"
Public Const strINIFile As String = "Undo.ini"
Public Const strErrorMessage As String = "Call Current Ops!"
'Read INI settings
Public Declare Function GetPrivateProfileString Lib "kernel32" Alias _
"GetPrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpDefault As String, _
ByVal lpReturnedString As String, ByVal nSize As Long, _
ByVal lpFileName As String) As Long
'Write INI settings
Public Declare Function WritePrivateProfileString Lib "kernel32" Alias _
"WritePrivateProfileStringA" (ByVal lpApplicationName As String, _
ByVal lpKeyName As Any, ByVal lpString As Any, _
ByVal lpFileName As String) As Long
Public Declare Function GetComputerName _
Lib "kernel32" Alias "GetComputerNameA" ( _
ByVal lpBuffer As String, nSize As Long) As Long
Type tpeEvent
Event As String
Explanation As String
ColorIndexBackground As Long
ColorIndexText As Long
End Type
Type tpeFooter
TotalAircraftOwned As Long
DepotInputs(100, 1) As Long '(0 - Normal, 1 - Departures)
ActualPossessed As Long
TACCPossessed As Long
CommittedAircraft As Long
DeployedAircraft(100) As Long
TACCDeployedAircraft As Long
MaintenanceWithhold As Long
TACCMaintenanceWithhold As Long
TACCFlyableTrainingFence As Long
TACCMXTraining As Long
MXTraining As Long
MXWithhold(2) As Double '(0 - Normal, 1 - % of yellow color start, 2 - % of red color start)
TaskedAircraft(100) As Long
TaskableAircraft As Long
TACCTaskableAircraft As Long
TaskableDeployedTraining As Long
TACCTaskableDeployedTraining As Long
PAC As Double
TACCPAC As Double
TaskableAircraftRemaining As Long
TACCTaskableAircraftRemaining As Long
CrewsTasked(100) As Long
CrewsDeployed(100) As Long
TotalCrewsTasked(4) As Long
TotalCrewsDeployed(4) As Long
TACCDeployedCrews As Long
Percent(3) As Double
TotalCrewsAvailable(3) As Long
TotalCrewsRemaining(3) As Long
TotalCombinedReserveTasked As Long
TotalCombinedReservePercent As Double
OSFenceAircraft(100) As Long
OSFenceCrews As Long
LocalFenceAircraft(100) As Long
LocalFenceCrews As Long
TotalFenceAircraft As Long
TotalFenceCrews As Long
MissionReadyCrews As Long
ReserveActivatedCrews As Long
TotalMissionReadyCrews As Long
End Type
Type tpeTables
CFG As Long
Crew As Long
Event As Long
EventType As Long
MSN As Long
Priority As Long
SQType As Long
Squadrons(1) As Long '0-Null, 1-Unassinged
Wing(1) As Long '0-Null, 1-Other
End Type
Type tpeProgramConstant
BackUpMonth As Long
Button(10) As String
ColumnWidth(1, 2) As Long '(0-Letter, 1-Legal), (0-First, 1-Day, 2-Last)
DocumentFolder As String
EventLine As Long 'Event Lines Per Page
FontSize(1) As Long '0-Letter, 1-Legal
PageScalling(1) As Long '0-Letter, 1-Legal
RowHeight(2) As Long '0-Comment, 1-Squadron, 2-Title
Squadrons(100, 5) As Variant
ViewZoom(1) As Long '0-Event, 1-Statistics
Wing(1) As Variant '0-ID, 1-Name
End Type
Dim lngColorIndexBackground As Long, lngColorIndexText As Long
Public Const conAdd As Integer = 1, conDelete As Integer = 2, conEdit As Integer = 3
Public Const conNoChange As Integer = 5
Public Const conLinkFront As Integer = 4, conDelinkFront As Integer = 5
Public Const conLinkBack As Integer = 6, conDelinkBack As Integer = 7, conCANX As Integer = 8
Public Const strFolderLocation As String = "In Your Documents Directory Under "
Public Const conBlack As Integer = 0
Public Const conBlue As Long = 16711680
Public Const conGreen As Long = 32768
Public Const conGrey As Long = 12632256
Public Const conGreenBright As Long = 65280
Public Const conGreenDark As Long = 32768
Public Const conRed As Integer = 255
Public Const conWhite As Long = 16777215
Public Const conYellow As Long = 5298411
Public Const conTransparent = 0
Public Const conSolid = 1
Public Const MAX_COMPUTERNAME_LENGTH As Long = 15&
Public Const MAX_PATH As Integer = 260
Public blnAutoClose As Boolean, blnButton As Boolean, blnTemp As Boolean
Public conEvent(50) As tpeEvent
Public Constant As tpeProgramConstant
Public ctlLostFocus As control
Public dblPAC As Double, dblPercentRedStart As Double, dblPercentYellowStart As Double, _
dblTemp As Double
Public dteTemp As Date
Public dteEnd As Date, dteFirst As Date, dteLast As Date, dteTACCEnd As Date, _
dteTACCStart As Date, dteStart As Date
Public dteOriginalEnd, dteOriginalStart, dteRelativeStart As Date
Public lngCounter As Long, lngNumberDays As Long, lngOrder As Long, lngOverallNumberDays As Long, _
lngPercent As Long, lngStartField As Long, lngTemp As Long
Public lngArrayNumber As Long
Public lngListCountAdjustment As Long
Public lngNullValues As tpeTables
Public lngPreviousFormNameCounter As Long
Public lngRowsToIgnore As Long
Public lngSQ(4, 2) As Long
Public lngTableCountAdjustment As Long
Public Numbers(63) As tpeFooter
Public strBenutzer As String
Public strDatabase As String, _
strFile As String, strLocation As String, strPath As String, _
strRootFolder As String, strSQL As String, strSQ(4, 2) As String, _
strTemp As String
Public strInfoText As String
Public strPreviousFormName(100) As String
Public strProgramVersion As String
Public strTableDesignator As String
Public strTableDesignatorTwo As String
Public varbookmark, varTemp
Public varTableArray(7, 100, 1000) '1-Event, 2-Squadron, 3-Availability/Trip List Output
'7-Wing
Public Function fnAddDaysToAvailability(dteStart, dteEnd)
Dim dteTemp As Date
Dim lngActive As Long, lngAircraft As Long, lngDepot As Long, _
lngLocalFenceAircraft As Long, lngLocalFenceCrews As Long, lngMRCrews As Long, _
lngMXTraining As Long, lngMXWithhold As Long, lngReserve As Long, _
lngTACCDeployed As Long, lngTACCDeployedCrews As Long, lngTACCFlyableTraining As Long, _
lngTACCMXTraining As Long, lngTACCPossessed As Long, lngTACCTaskable As Long
Dim lngReserveCrewsActivated As Long
strSQL = "SELECT * FROM defaults;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
lngTACCPossessed = rstTempADO!tacc_possessed
lngActive = rstTempADO!Active
lngReserve = rstTempADO!reserve
lngTACCDeployedCrews = rstTempADO!tacc_deployed_crews
lngAircraft = rstTempADO!aircraft
lngTACCFlyableTraining = rstTempADO!tacc_flyable_training
lngTACCMXTraining = rstTempADO!tacc_mx_training
lngMXWithhold = rstTempADO!mx_withhold
lngTACCDeployed = rstTempADO!tacc_deployed
lngTACCTaskable = rstTempADO!tacc_taskable
lngMRCrews = rstTempADO!active_mr_crews
lngLocalFenceCrews = rstTempADO!local_fence_crews
lngLocalFenceAircraft = rstTempADO!local_fence_aircraft
lngMXTraining = rstTempADO!mx_training
lngReserveCrewsActivated = rstTempADO!reserve_mr_crews
End If
rstTempADO.Close
fnImportTableIntoArray 3, dteStart, dteEnd
dteTemp = dteStart
Do
lngTemp = fnFindIDinArray(3, 0, dteTemp)
If lngTemp = 0 Then
strSQL = "INSERT INTO availability ( datum, taccactive, taccreserve, aircraft, " & _
"taccflyabletraining, taccmxtraining, mxtraining, mxwithhold, " & _
"taccpossessedaircraft, taccdeployed, tacctaskable, taccmrcrews, " & _
"taccdeployedcrews, localtrainingcrews, localtrainingaircraft, " & _
"reservecrewsactivated ) " & _
"VALUES ( #" & dteTemp & "#, " & _
lngActive & ", " & _
lngReserve & ", " & _
lngAircraft & ", " & _
lngTACCFlyableTraining & ", " & _
lngTACCMXTraining & ", " & _
lngMXTraining & ", " & _
lngMXWithhold & ", " & _
lngTACCPossessed & ", " & _
lngTACCDeployed & ", " & _
lngTACCTaskable & ", " & _
lngMRCrews & ", " & _
lngTACCDeployedCrews & ", " & _
lngLocalFenceCrews & ", " & _
lngLocalFenceAircraft & ", " & _
lngReserveCrewsActivated & " );"
dbADO.Execute strSQL
End If
dteTemp = DateAdd("d", 1, dteTemp)
Loop Until dteTemp = DateAdd("d", 1, dteEnd)
End Function
Public Function fnAddDeleteInUse(lngFrontLink, lngID, lngBackLink)
On Error GoTo Err_AddDeleteInUse
'Delete all records with that Username
strSQL = "DELETE " & _
"FROM InUse " & _
"WHERE benutzer = '" & strBenutzer & "';"
dbADO.Execute strSQL
If Not lngFrontLink = 0 Then
strSQL = "INSERT INTO InUse ( ID, benutzer ) " & _
"VALUES (" & lngFrontLink & ", '" & strBenutzer & "');"
dbADO.Execute strSQL
End If
If Not lngBackLink = 0 Then
strSQL = "INSERT INTO InUse ( ID, benutzer ) " & _
"VALUES (" & lngBackLink & ", '" & strBenutzer & "');"
dbADO.Execute strSQL
End If
If Not lngID = 0 Then
strSQL = "INSERT INTO InUse ( ID, benutzer ) " & _
"VALUES (" & lngID & ", '" & strBenutzer & "');"
dbADO.Execute strSQL
End If
Exit Function
Err_AddDeleteInUse:
Select Case Err.Number
Case -2147217865, -2147217904
Resume Next
Case 3420, 91
fnSetDatabase
Resume
Case Else
fnErrorHandler "fnAddDeleteInUse"
MsgBox strErrorMessage
End Select
End Function
Public Function fnAddSubtractDay(cntTemp, intASCII) As Boolean
On Error GoTo Err_fnAddSubtractDay
fnAddSubtractDay = True
Select Case intASCII
Case 43
cntTemp.Value = Format(DateAdd("d", 1, Left(cntTemp.Value, 2) & "-" & _
Mid(cntTemp.Value, 3, 2) & "-" & Right(cntTemp.Value, 2)), "mmddyy")
Case 45
cntTemp.Value = Format(DateAdd("d", -1, Left(cntTemp.Value, 2) & "-" & _
Mid(cntTemp.Value, 3, 2) & "-" & Right(cntTemp.Value, 2)), "mmddyy")
End Select
Exit Function
Err_fnAddSubtractDay:
Select Case Err.Number
Case 13
fnAddSubtractDay = False
Case 51
Resume Next
Case Else
fnErrorHandler "fnAddSubtractDay"
MsgBox strErrorMessage
End Select
End Function
Public Function fnBackup() As String
On Error GoTo Err_fnBackup
If blnSquadron Then Exit Function
Dim lngBackupCounter As Long
Dim strTableName As String
DoCmd.OpenForm "Progress", , , , , , "Backing Up Data"
Forms!Progress.Repaint
Forms!Progress.pbProgress.Max = varTableArray(6, 0, 0) + 3
'If the directory already existed do the following
If fnCreateDirectory(strRootFolder, strBackupDirectory) = False Then
strFile = Dir(strRootFolder & strBackupDirectory & "\*Backup.mdb")
'Delete all Backup Files that are older than 8 days
Do While strFile <> ""
If Val(Left(strFile, 8)) < Val(Format(DateAdd("d", -8, Now()), "yyyymmdd")) Then
Kill strRootFolder & strBackupDirectory & "\" & strFile
End If
strFile = Dir
Loop
End If
Forms!Progress.pbProgress.Value = Forms!Progress.pbProgress.Value + 1
strFile = strRootFolder & strBackupDirectory & "\" & Format(Now(), "yyyymmdd hhmmss") & _
" Backup.mdb"
Forms!Progress.pbProgress.Value = Forms!Progress.pbProgress.Value + 1
FileCopy Application.CurrentProject.Path & "\" & strBackUpDatabaseFile, strFile
Forms!Progress.pbProgress.Value = Forms!Progress.pbProgress.Value + 1
For lngBackupCounter = 1 To varTableArray(6, 0, 0)
fnBackupInto varTableArray(6, 0, lngBackupCounter)
Forms!Progress.pbProgress.Value = Forms!Progress.pbProgress.Value + 1
Next
fnBackup = strFile
DoCmd.Close acForm, "Progress"
Exit Function
Err_fnBackup:
Select Case Err.Number
Case -2147217843
fnSetDatabase
Resume
Case 70, 75
Resume Next
Case 53
Exit Function
Case Else
fnErrorHandler "fnBackup"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnChangeColors(xls, strField, lngSelection)
Dim strCellValue As String
xls.Range(strField).Select
strCellValue = xls.ActiveCell.Value
With xls
Select Case lngSelection
Case 1
fnChangeEventColor strCellValue
Case 2
fnGreenYellowRed strCellValue
Case 3
fnChangeSquadronColor strCellValue
Case 4
fnChangeDayColor strCellValue
Case 5
fnGreenYellowRedPercent
End Select
End With
xls.Range(strField).Interior.ColorIndex = lngColorIndexBackground
xls.Range(strField).Font.ColorIndex = lngColorIndexText
End Function
Public Function fnChangeDayColor(strCellValue)
lngColorIndexBackground = 2
lngColorIndexText = 1
Select Case UCase(strCellValue)
Case "SAT", "SUN"
lngColorIndexBackground = 34
End Select
End Function
Public Function fnChangeEventColor(strCellValue)
lngColorIndexBackground = 2
lngCounter = 0
lngColorIndexText = 1
Do While conEvent(lngCounter).Event <> ""
If strCellValue = conEvent(lngCounter).Event Then
lngColorIndexBackground = conEvent(lngCounter).ColorIndexBackground
lngColorIndexText = conEvent(lngCounter).ColorIndexText
Exit Do
End If
lngCounter = lngCounter + 1
Loop
End Function
Public Function fnChangeOrder( _
lst As ListBox, _
DownDirection As Boolean, _
TableName As String, _
CriteriaColumn As String, _
CriteriaValue As Long, _
OrderColumnName As String, _
OrderColumnValue As Long, _
ListCountAdjustment As Long) As Long
On Error GoTo Hell
Dim lngFrom As Long, lngTo As Long
Dim strSQL As String
lngFrom = OrderColumnValue
If (lngFrom = 1 And DownDirection = False) _
Or (lngFrom = lst.ListCount - ListCountAdjustment And DownDirection = True) Then
Exit Function
Else
strSQL = "UPDATE " & TableName & " SET " & _
OrderColumnName & " = 0 " & _
"WHERE (" & CriteriaColumn & " = " & CriteriaValue & " " & _
"AND " & OrderColumnName & " = " & OrderColumnValue & ");"
dbADO.Execute strSQL
End If
If DownDirection = True Then
lngTo = lngFrom + 1
Else
lngTo = lngFrom - 1
End If
strSQL = "UPDATE " & TableName & " SET " & _
OrderColumnName & " = " & lngFrom & " " & _
"WHERE (" & CriteriaColumn & " = " & CriteriaValue & " " & _
"AND " & OrderColumnName & "=" & lngTo & ");"
dbADO.Execute strSQL
strSQL = "UPDATE " & TableName & " SET " & _
OrderColumnName & " = " & lngTo & " " & _
"WHERE (" & CriteriaColumn & " = " & CriteriaValue & " " & _
"AND " & OrderColumnName & "=0);"
dbADO.Execute strSQL
fnChangeOrder = lngTo
Exit Function
Hell:
Select Case Err.Number
Case 91, 3240
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnChangeOrder"
MsgBox strErrorMessage
End Select
End Function
Public Function fnChangeOrderSimple( _
lst As ListBox, _
TableName As String, _
OrderColumnName As String, _
OrderColumnValue As Long, _
AddSubtractNumber As Long, _
ListCountAdjustment As Long, _
TableCountAdjustment As Long, _
Form As Form) As Long
On Error GoTo Hell
fnCheckSession Form.Name
Dim lngFrom As Long, lngTo As Long
Dim strSQL As String
lngFrom = OrderColumnValue
If (lngFrom - TableCountAdjustment = 1 And AddSubtractNumber < 0) _
Or (lngFrom - TableCountAdjustment = lst.ListCount - ListCountAdjustment _
And AddSubtractNumber > 0) Then Exit Function
lngTo = lngFrom + AddSubtractNumber
strSQL = "UPDATE " & TableName & " SET " & _
OrderColumnName & " = 0 " & _
"WHERE (" & OrderColumnName & "=" & lngFrom & ");"
dbADO.Execute strSQL
strSQL = "UPDATE " & TableName & " SET " & _
OrderColumnName & " = " & lngFrom & " " & _
"WHERE (" & OrderColumnName & "=" & lngTo & ");"
dbADO.Execute strSQL
strSQL = "UPDATE " & TableName & " SET " & _
OrderColumnName & " = " & lngTo & " " & _
"WHERE (" & OrderColumnName & "=0);"
dbADO.Execute strSQL
fnChangeOrderSimple = lngTo
Exit Function
Hell:
Select Case Err.Number
Case 91, 3240
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnChangeOrderSimple"
MsgBox strErrorMessage
End Select
End Function
Public Function fnChangeSquadronColor(strCellValue)
lngColorIndexBackground = 2
lngCounter = 1
lngColorIndexText = 1
Do While lngCounter < 7
If strCellValue = Constant.Squadrons(lngCounter, 0) Then
lngColorIndexBackground = Constant.Squadrons(lngCounter, 2)
lngColorIndexText = Constant.Squadrons(lngCounter, 3)
Exit Do
End If
lngCounter = lngCounter + 1
Loop
End Function
Public Function fnCheckControl( _
clt As control, _
blnMessage As Boolean) As Boolean
On Error GoTo Err_fnCheckControl
If clt.Visible Then
' clt.SetFocus
'varTemp = clt.Text
varTemp = clt
Else
varTemp = Null
End If
If Trim(clt.Value) = "" Or IsNull(clt.Value) = True Or varTemp = "" Then
If blnMessage Then
MsgBox clt.Tag & " Required"
clt.SetFocus
End If
fnCheckControl = False
Exit Function
End If
fnCheckControl = True
Exit Function
Err_fnCheckControl:
Select Case Err.Number
Case 438
varTemp = Null
Resume Next
Case Else
fnErrorHandler "fnCheckControl"
MsgBox strErrorMessage
Resume Next
End Select
End Function
'Public Function fnCheckControl(clt) As Boolean
' If Trim(clt.Value) = "" Or IsNull(clt.Value) = True Then
' MsgBox clt.Tag & " Required"
' clt.SetFocus
' fnCheckControl = False
' Exit Function
' End If
' fnCheckControl = True
'End Function
Public Function fnCheckForItemInList( _
LookingFor, InList As Object, ListColumn As Long) As Variant
Dim lngRowCounter As Long
Dim varItem As Variant
fnCheckForItemInList = Null
If IsNull(LookingFor) Then Exit Function
If InList.ListCount = 0 Then Exit Function
For lngRowCounter = 0 To InList.ListCount
varTemp = Nz(InList.Column(ListColumn, lngRowCounter), "-1")
If varTemp = "" Then varTemp = "-1"
If Val(varTemp) = Val(LookingFor) Then
InList.Value = InList.ItemData(lngRowCounter)
fnCheckForItemInList = lngRowCounter
Exit Function
End If
Next
End Function
Public Function fnCheckInUse(lngID) As Boolean
Dim lngRecordCount As Long
Dim varRecordUsername As Variant, varUsername As Variant
fnCheckInUse = False
If IsNull(lngID) Then Exit Function
strSQL = fnSelectInUseID(lngID)
rstTablesADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
lngRecordCount = rstTablesADO.RecordCount
If Not rstTablesADO.EOF Then
rstTablesADO.MoveFirst
varRecordUsername = rstTablesADO!benutzer
End If
rstTablesADO.Close
varUsername = fnGetUsername
If IsEmpty(varRecordUsername) = False And varRecordUsername <> varUsername Then
MsgBox "User: " & varRecordUsername & _
" Is Currently Working With One Of The Effected Records!"
fnCheckInUse = True
End If
End Function
Public Function fnCheckSession(FormName As String) As Boolean
fnCheckSession = True
If strDatabase = "" Then
MsgBox "Session Was Interrupted! Attempting to Reconnect and Return To Main Menu!"
fnCloseOpenForm FormName, "Main"
fnCheckSession = False
End If
End Function
Public Function fnClearField(Record, FieldName As Object)
FieldName = Null
Record!Change = Now()
Record.Update
End Function
Public Function fnClearRowCells(ctl, RowCount, ColumnCount)
Dim lngControlCounter As Long
Dim lngRowCounter As Long
For lngRowCounter = 1 To RowCount
For lngControlCounter = 1 To ColumnCount
ctl(lngRowCounter, lngControlCounter) = ""
Next
Next
End Function
Public Function fnClearRowColor(ctl, ListRowToClear, ColumnCount, ScollValue)
Dim lngControlCounter As Long
For lngControlCounter = 1 To ColumnCount
If IsEmpty(varTableArray(lngArrayNumber, 98, ListRowToClear + ScollValue)) Then
ctl(ListRowToClear, lngControlCounter).BackColor _
= conWhite
Else
ctl(ListRowToClear, lngControlCounter).BackColor _
= varTableArray(lngArrayNumber, 98, ListRowToClear + ScollValue)
ctl(ListRowToClear, lngControlCounter).ForeColor _
= varTableArray(lngArrayNumber, 99, ListRowToClear + ScollValue)
End If
ctl(ListRowToClear, lngControlCounter).BorderStyle = conTransparent
Next
End Function
Public Function fnCloseCurrentFormOpenNext(CurrentForm As Form, NewFormName As String)
blnButton = True
If fnCheckSession(CurrentForm.Name) = False Then Exit Function
lngPreviousFormNameCounter = lngPreviousFormNameCounter + 1
strPreviousFormName(lngPreviousFormNameCounter) = CurrentForm.Name
fnCloseOpenForm CurrentForm.Name, NewFormName
End Function
Public Function fnCloseCurrentFormOpenPrevious(CurrentForm As Form)
blnButton = True
If fnCheckSession(CurrentForm.Name) = False Then Exit Function
'If the form was entered from the "Select Person" form an extra form count
'needs to be deleted
If strPreviousFormName(lngPreviousFormNameCounter) = "Select Person" Then
lngPreviousFormNameCounter = lngPreviousFormNameCounter - 1
End If
fnCloseOpenForm CurrentForm.Name, strPreviousFormName(lngPreviousFormNameCounter)
If lngPreviousFormNameCounter > 0 Then
lngPreviousFormNameCounter = lngPreviousFormNameCounter - 1
End If
End Function
Public Function fnCloseOpenForm(objClose, objOpen)
Dim strClose As String, strOpen As String
DoCmd.Close acForm, objClose
DoCmd.OpenForm objOpen
End Function
Public Function fnConfigureTables()
On Error GoTo Hell
'This is only used when manually configuring tables
' fnOpenADOConnection
fnCreatePrimaryIndex "availability_datumid", "availability", "datum"
fnCreatePrimaryIndex "buttons_idid", "buttons", "id"
fnCreatePrimaryIndex "cfg_idid", "cfg", "id"
fnCreatePrimaryIndex "colors_idid", "colors", "id"
fnCreatePrimaryIndex "ce_eventid", "color_event", "event"
fnCreatePrimaryIndex "cs_squadronsid", "color_squadrons", "squadrons"
fnCreatePrimaryIndex "cw_wingid", "color_wing", "wing"
fnCreatePrimaryIndex "constants_idid", "constants", "id"
fnCreatePrimaryIndex "crew_idid", "crew", "id"
fnCreatePrimaryIndex "dates_idid", "dates", "id"
fnCreatePrimaryIndex "defaults_idid", "defaults", "id"
fnCreatePrimaryIndex "event_idid", "event", "id"
fnCreatePrimaryIndex "eventtype_idid", "eventtype", "id"
fnCreatePrimaryIndex "inuse_idid", "inuse", "id"
fnCreatePrimaryIndex "msn_idid", "msn", "id"
fnCreatePrimaryIndex "patch_idid", "patch", "id"
fnCreatePrimaryIndex "priority_idid", "priority", "id"
fnCreatePrimaryIndex "sqtype_idid", "sqtype", "id"
fnCreatePrimaryIndex "squadrons_idid", "squadrons", "id"
fnCreatePrimaryIndex "taskings_idid", "taskings", "id"
fnCreateIndex "taskings_startid", "taskings", "start"
fnCreateIndex "taskings_endid", "taskings", "end"
fnCreateIndex "taskings_startid_endid", "taskings", "start,end"
fnCreateIndex "taskings_eventid", "taskings", "event"
fnCreateIndex "taskings_frontlinkid", "taskings", "frontlink"
fnCreateIndex "taskings_backlinkid", "taskings", "backlink"
fnCreatePrimaryIndex "wing_idid", "wing", "id"
'This is only used when manually configuring tables
' fnCloseADOConnection
Exit Function
Hell:
Select Case Err.Number
Case 70, 75, 3146, -2147467259
' fnErrorHandler "fnExportInto"
Resume Next
Case 53
Exit Function
Case Else
fnErrorHandler "fnExportInto"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnConvertColumNumberToLetters(lngColumnNumber) As String
Dim lng As Long
lng = lngColumnNumber + 64
Select Case lng
Case Is < 91
fnConvertColumNumberToLetters = Chr(lng)
Case 91 To 116
fnConvertColumNumberToLetters = "A" & Chr(lng - 26)
Case Else
fnConvertColumNumberToLetters = "B" & Chr(lng - 52)
End Select
End Function
Public Function fnConvertValueToDate(control) As String
fnConvertValueToDate = Left(control.Value, 2) & "-" & Mid(control.Value, 3, 2) & "-" & _
Right(control.Value, 2)
End Function
Public Function fnCountSquadronTraining(obj As tpeFooter, EventType)
Dim lngSQCount As Long
With obj
'Count Squadron
For lngTemp = 1 To 4
For lngSQCount = 1 To varTableArray(2, 0, 0)
If Constant.Squadrons(lngSQCount, 5) <> 0 And lngSQ(lngTemp, 0) <> 0 Then
If Constant.Squadrons(lngSQCount, 5) = lngSQ(lngTemp, 0) _
And Constant.Squadrons(lngSQCount, 4) = "1" Then
'Local
If EventType = 5 Then
.LocalFenceCrews = .LocalFenceCrews + 1
Else
.OSFenceCrews = .OSFenceCrews + 1
End If
Exit For
End If
Else
Exit For
End If
Next
Next
End With
End Function
Public Function fnCountSquadronTaskings( _
EventType As Long, _
obj As tpeFooter, _
objOverall As tpeFooter)
Dim lngSQCount As Long
With obj
'Count Squadron Taskings
For lngTemp = 1 To 4
For lngSQCount = 1 To varTableArray(2, 0, 0)
If Constant.Squadrons(lngSQCount, 5) <> 0 And lngSQ(lngTemp, 0) <> 0 Then
If Constant.Squadrons(lngSQCount, 5) = lngSQ(lngTemp, 0) Then
'Chopped
If EventType = 2 Then
.CrewsDeployed(lngSQCount) = .CrewsDeployed(lngSQCount) + 1
objOverall.CrewsDeployed(lngSQCount) _
= objOverall.CrewsDeployed(lngSQCount) + 1
Else
.CrewsTasked(lngSQCount) = .CrewsTasked(lngSQCount) + 1
objOverall.CrewsTasked(lngSQCount) _
= objOverall.CrewsTasked(lngSQCount) + 1
End If
Exit For
End If
Else
Exit For
End If
Next
Next
End With
End Function
Public Function fnCountWingTaskings( _
EventType As Long, _
obj As tpeFooter, _
objOverall As tpeFooter, _
LookForWingID As Long)
Dim lngWingCount As Long
'Count Wing Taskings, Start at 2 to ignore None Wings
For lngWingCount = 2 To varTableArray(7, 0, 0)
If varTableArray(7, 0, lngWingCount) <> 0 And LookForWingID <> 0 Then
If varTableArray(7, 0, lngWingCount) = LookForWingID Then
'Chopped
If EventType = 2 Then
obj.DeployedAircraft(lngWingCount) = obj.DeployedAircraft(lngWingCount) + 1
objOverall.DeployedAircraft(lngWingCount) _
= objOverall.DeployedAircraft(lngWingCount) + 1
Else
obj.TaskedAircraft(lngWingCount) = obj.TaskedAircraft(lngWingCount) + 1
objOverall.TaskedAircraft(lngWingCount) _
= objOverall.TaskedAircraft(lngWingCount) + 1
End If
Exit For
End If
Else
Exit For
End If
Next lngWingCount
End Function
Public Function fnCountWingTraining( _
ColumnDate, _
DepartureDate As Date, _
EventType As Long, _
obj As tpeFooter, _
objOverall As tpeFooter, _
LookForWingID As Long)
Dim lngWingCount As Long
'Count Wing Taskings, Start at 2 to ignore None Wings
For lngWingCount = 2 To varTableArray(7, 0, 0)
If varTableArray(7, 0, lngWingCount) <> 0 And LookForWingID <> 0 Then
If varTableArray(7, 0, lngWingCount) = LookForWingID Then
'Local
If EventType = 5 Then
obj.LocalFenceAircraft(lngWingCount) = obj.LocalFenceAircraft(lngWingCount) + 1
objOverall.LocalFenceAircraft(lngWingCount) _
= objOverall.LocalFenceAircraft(lngWingCount) + 1
ElseIf EventType = 3 Then
If DateValue(ColumnDate) = _
DateValue(DepartureDate) Then
obj.DepotInputs(lngWingCount, 1) = obj.DepotInputs(lngWingCount, 1) + 1
End If
obj.DepotInputs(lngWingCount, 0) = obj.DepotInputs(lngWingCount, 0) + 1
objOverall.DepotInputs(lngWingCount, 0) _
= objOverall.DepotInputs(lngWingCount, 0) + 1
Else
obj.OSFenceAircraft(lngWingCount) = obj.OSFenceAircraft(lngWingCount) + 1
objOverall.OSFenceAircraft(lngWingCount) _
= objOverall.OSFenceAircraft(lngWingCount) + 1
End If
Exit For
End If
Else
Exit For
End If
Next lngWingCount
End Function
Public Function fnCreateDirectory( _
strRootDirectoryPath As String, _
strDirectoryName As String) As Boolean
Dim strDirectory As String
strDirectory = Dir(strRootDirectoryPath, vbDirectory)
Do While strDirectory <> ""
If strDirectory = strDirectoryName Then
fnCreateDirectory = False
Exit Function
End If
strDirectory = Dir
Loop
MkDir strRootDirectoryPath & strDirectoryName
fnCreateDirectory = True
End Function
Public Function fnCreateIndex( _
IndexName As String, _
TableName As String, _
FieldNames As String)
On Error GoTo Hell
strSQL = "CREATE INDEX " & IndexName & " " & _
"ON " & TableName & " (" & FieldNames & ");"
'Debug.Print strSQL
dbADO.Execute strSQL
Exit Function
Hell:
Select Case Err.Number
Case 3283, 3375, -2147467259, -2147217900
Resume Next
Case Else
fnErrorHandler "Main / fnCreateIndex"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnCreatePrimaryIndex( _
UniqueIndexName As String, _
TableName As String, _
FieldNames As String)
On Error GoTo Hell
strSQL = "CREATE UNIQUE INDEX " & UniqueIndexName & " " & _
"ON " & TableName & " (" & FieldNames & ");"
dbADO.Execute strSQL
Exit Function
Hell:
Select Case Err.Number
Case 3283, -2147467259, -2147217900, -2147217865
Resume Next
Case Else
fnErrorHandler "Main / fnCreatePrimaryIndex"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnCurrentMachineName() As String
Dim lSize As Long
Dim sBuffer As String
sBuffer = Space$(MAX_COMPUTERNAME_LENGTH + 1)
lSize = Len(sBuffer)
If GetComputerName(sBuffer, lSize) Then
fnCurrentMachineName = Left$(sBuffer, lSize)
End If
End Function
Public Function fnFillComboGeneric(TableName As String, FieldName As String, cb As ComboBox)
strSQL = "SELECT id, " & FieldName & " " & _
"FROM " & TableName & " " & _
"ORDER BY " & FieldName & ";"
'Debug.Print strSQL & Chr(10)
fnFillRowSourse cb, strSQL, ""
End Function
Public Function fnFillComboStandard(TableName As String, cb As ComboBox, RowsToIgnore)
strSQL = "SELECT id, lang, kurz " & _
"FROM " & TableName & " " & _
"WHERE folge > " & RowsToIgnore & " " & _
"ORDER BY folge;"
'Debug.Print strSQL & Chr(10)
fnFillRowSourse cb, strSQL, ""
End Function
Public Function fnFillComboColorIndexes(ComboBackground As ComboBox, ComboText As ComboBox)
strSQL = "SELECT ColorIndex FROM Colors ORDER BY ColorIndex;"
fnFillRowSourse ComboBackground, strSQL, ""
fnFillRowSourse ComboText, strSQL, ""
End Function
Public Function fnFillComboEvent(cb As ComboBox) As Boolean
On Error GoTo Hell
fnFillComboEvent = True
strSQL = "SELECT id, lang FROM event " & _
"ORDER BY folge;"
'Debug.Print strSQL
fnFillRowSourse cb, strSQL, ""
Exit Function
Hell:
Select Case Err.Number
Case 91, 3420, 3240, -2147217843
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnFillComboEvent"
MsgBox strErrorMessage
End Select
End Function
Public Function fnFillRowSourse(cb As control, SQLStatement As String, Heading As String)
On Error GoTo Hell
'Debug.Print SQLStatement
rstTempADO.Open SQLStatement, dbADO, adOpenStatic, adLockReadOnly
If rstTempADO.EOF Then
cb.RowSource = ""
Else
cb.RowSource = Heading & rstTempADO.GetString(adClipString, , ";", ";")
End If
rstTempADO.Close
Exit Function
Hell:
Select Case Err.Number
Case 91, 3420, 3240
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnFillRowSource"
MsgBox strErrorMessage
End Select
End Function
Public Function fnFindColorNumber(ColorIndexNumber) As Long
Dim intBlue As Integer
Dim intGreen As Integer
Dim intRed As Integer
lngTemp = fnFindIDinArray(5, 0, ColorIndexNumber)
intBlue = varTableArray(5, 1, lngTemp)
intGreen = varTableArray(5, 2, lngTemp)
intRed = varTableArray(5, 3, lngTemp)
fnFindColorNumber = RGB(intRed, intGreen, intBlue)
End Function
Public Function fnFindMaxID(TableName) As Long
Dim strSQL As String
Dim varMaxID
strSQL = "SELECT MAX(id) as lastid FROM " & TableName & ";"
rstTablesADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly, adCmdText
varMaxID = rstTablesADO!lastid
If IsNull(varMaxID) Then
fnFindMaxID = 0
Else
fnFindMaxID = varMaxID
End If
rstTablesADO.Close
End Function
Public Function fnFindRecordID(strRecord, strField, LookFor) As Long
'I guess this function finds the record that corresponse to the record that
'depicts none or n/a
rstTablesADO.Open strRecord, dbADO, adOpenStatic, adLockReadOnly
rstTablesADO.Find strField & " = " & LookFor
fnFindRecordID = rstTablesADO!Id
rstTablesADO.Close
End Function
Public Function fnFindRecordInSQLRecordset(Record, lngID) As Boolean
On Error GoTo Hell
Record.MoveLast
Record.MoveFirst
fnFindRecordInSQLRecordset = False
'Find first record satisfying search criteria
Record.Find "ID = " & Trim(Str(lngID))
If Not Record.EOF Then
'successful search
fnFindRecordInSQLRecordset = True
End If
Exit Function
Hell:
Select Case Err.Number
Case -2147217885
End Select
End Function
Public Function fnDeleteCreateFile( _
FileCriteria As String, _
DeleteFiles As Boolean, _
TemplateFile As Boolean) As String
On Error GoTo Err_fnDeleteCreateFile
Dim strDeleteCreateFolder As String
strDeleteCreateFolder = strRootFolder & Constant.DocumentFolder & "\"
strFile = Dir(strDeleteCreateFolder & "*" & FileCriteria)
'Debug.Print strFile
If DeleteFiles Then
'Delete all Files
Do While strFile <> ""
Kill strDeleteCreateFolder & strFile
strFile = Dir
Loop
End If
fnDeleteCreateFile = strDeleteCreateFolder & _
Format(Now(), "yyyymmdd hhmmss") & " " & FileCriteria
'Debug.Print fnDeleteCreateFile
If TemplateFile Then
FileCopy Application.CurrentProject.Path & "\" & FileCriteria, fnDeleteCreateFile
End If
Exit Function
Err_fnDeleteCreateFile:
Select Case Err.Number
Case 70, 49
Resume Next
End Select
End Function
Public Function fnDeleteIndex( _
IndexName As String, _
TableName As String)
On Error GoTo Hell
Dim strSQL As String
strSQL = "DROP INDEX " & IndexName & " " & _
"ON " & TableName & ";"
'Debug.Print strSQL
dbADO.Execute strSQL
Exit Function
Hell:
Select Case Err.Number
Case 3283, 3375, -2147467259
Resume Next
Case Else
fnErrorHandler "Main / fnDeleteIndex"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnDeleteRecord( _
TableName As String, _
CriteriaColumnName As String, _
CriteriaValue)
Dim strSQL As String
strSQL = "DELETE FROM " & TableName & " " & _
"WHERE " & CriteriaColumnName & " = " & CriteriaValue & ";"
dbADO.Execute strSQL
End Function
Public Function fnDeleteTable(TableName As String)
strSQL = "DROP TABLE " & TableName & ";"
dbADO.Execute strSQL
End Function
Public Function fnDisable(obj)
obj.Enabled = False
End Function
Public Function fnEditField(Record, FieldName, lngID)
FieldName = lngID
Record!Change = Now()
Record.Update
End Function
Public Function fnEnable(obj)
obj.Enabled = True
End Function
Public Function fnExitProgram()
On Error GoTo Err_fnExitProgram
Dim mybar As Object
Set mybar = CommandBars("Main")
mybar.Enabled = False
Set mybar = CommandBars("Default")
mybar.Enabled = True
Call fnBackup
fnWriteINI fnCurrentMachineName, "User", fnGetUsername & " Offline"
fnCloseADOConnection
If blnMaintenance = False Then DoCmd.Quit acQuitPrompt
Exit Function
Err_fnExitProgram:
Select Case Err.Number
Case 75, 3420, 91
Resume Next
Case Else
fnErrorHandler "fnExitProgram"
MsgBox strErrorMessage
End Select
End Function
Public Function fnErrorHandler(strProcedure)
Dim strFileName As String
strFileName = Application.CurrentProject.Path & "\Error.txt"
Open strFileName For Append As #1 ' Open file for output.
Write #1, Format(Now(), "yyyymmdd hhmm") & " | " & Err.Number & " | " & Err.Description & _
" | " & strProcedure
Close #1 ' Close file.
End Function
Public Function fnGreenYellowRed(strTemp)
lngColorIndexText = 1
Select Case Val(strTemp)
Case Is > 0
lngColorIndexBackground = 35
Case "0"
lngColorIndexBackground = 6
Case Is < 0
lngColorIndexBackground = 3
Case Else
lngColorIndexBackground = 2
End Select
End Function
Public Function fnGreenYellowRedPercent()
lngColorIndexText = 1
Select Case dblPAC
Case Is < dblPercentYellowStart
lngColorIndexBackground = 35
Case Is >= dblPercentRedStart
lngColorIndexBackground = 3
Case Is >= dblPercentYellowStart
lngColorIndexBackground = 6
Case Else
lngColorIndexBackground = 2
End Select
End Function
Public Function fnLoadConstants()
On Error GoTo Err_fnLoadConstants
strSQL = "SELECT * FROM buttons;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
With Constant
.Button(1) = rstTempADO!Button01
.Button(2) = rstTempADO!Button02
.Button(3) = rstTempADO!Button03
.Button(4) = rstTempADO!Button04
.Button(5) = rstTempADO!Button05
.Button(6) = rstTempADO!Button06
.Button(7) = rstTempADO!Button07
.Button(8) = rstTempADO!Button08
.Button(9) = rstTempADO!Button09
.Button(10) = rstTempADO!Button10
End With
End If
rstTempADO.Close
strSQL = "SELECT * FROM constants;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
With Constant
.BackUpMonth = rstTempADO!backup_month
.ColumnWidth(0, 0) = rstTempADO!column_width00
.ColumnWidth(0, 1) = rstTempADO!column_width01
.ColumnWidth(0, 2) = rstTempADO!column_width02
.ColumnWidth(1, 0) = rstTempADO!column_width10
.ColumnWidth(1, 1) = rstTempADO!column_width11
.ColumnWidth(1, 2) = rstTempADO!column_width12
.DocumentFolder = rstTempADO!document_folder
.EventLine = rstTempADO!EventLine
.FontSize(0) = rstTempADO!font_size0
.FontSize(1) = rstTempADO!font_size1
.PageScalling(0) = rstTempADO!page_scalling0
.PageScalling(1) = rstTempADO!page_scalling1
.RowHeight(0) = rstTempADO!row_height0
.RowHeight(1) = rstTempADO!row_height1
.RowHeight(2) = rstTempADO!row_height2
.ViewZoom(0) = rstTempADO!view_zoom0
.ViewZoom(1) = rstTempADO!view_zoom1
'Folge = 3 is the default wing
lngTemp = fnFindIDinArray(7, 5, 3)
.Wing(0) = varTableArray(7, 0, lngTemp)
.Wing(1) = varTableArray(7, 1, lngTemp)
End With
End If
rstTempADO.Close
' Numbers(0).MXWithhold(0) = fnReadINI("Defaults", "MXWithhold")
With Constant
fnImportTableIntoArray 2, Null, Null
lngCounter = 1
For lngTemp = 1 To varTableArray(2, 0, 0)
If Not IsNull(varTableArray(2, 1, lngTemp)) Then
.Squadrons(lngCounter, 0) = varTableArray(2, 1, lngTemp)
.Squadrons(lngCounter, 1) = varTableArray(2, 2, lngTemp)
.Squadrons(lngCounter, 2) = varTableArray(2, 3, lngTemp)
.Squadrons(lngCounter, 3) = varTableArray(2, 4, lngTemp)
.Squadrons(lngCounter, 4) = varTableArray(2, 5, lngTemp)
.Squadrons(lngCounter, 5) = varTableArray(2, 0, lngTemp)
lngCounter = lngCounter + 1
End If
Next lngTemp
.Squadrons(0, 0) = lngCounter - 1
End With
Exit Function
Err_fnLoadConstants:
Select Case Err.Number
Case 91, 3420
fnSetDatabase
Resume
Case Else
fnErrorHandler "fnLoadConstants"
MsgBox strErrorMessage
End Select
End Function
Public Function Ne(Value, ValueIfEmpty) As Variant
Ne = IIf(IsEmpty(Value), ValueIfEmpty, Value)
End Function
Public Function fnInvisible(obj)
obj.Visible = False
End Function
Public Function fnLoadconEvent()
Erase conEvent
lngCounter = 0
For lngTemp = 1 To varTableArray(1, 0, 0)
conEvent(lngCounter).Event = varTableArray(1, 1, lngTemp)
conEvent(lngCounter).Explanation = varTableArray(1, 2, lngTemp)
conEvent(lngCounter).ColorIndexBackground = varTableArray(1, 3, lngTemp)
conEvent(lngCounter).ColorIndexText = varTableArray(1, 4, lngTemp)
lngCounter = lngCounter + 1
Next lngTemp
End Function
Public Function fnNumberDaysStartField() As Date
Dim dteTempFirst As Date, dteTempLast As Date
If DateValue(dteOriginalStart) < DateValue(dteFirst) Then
dteTempFirst = dteFirst
Else
dteTempFirst = dteOriginalStart
End If
lngStartField = DateValue(dteTempFirst) - DateValue(dteFirst) + 1
If DateValue(dteEnd) > DateValue(dteLast) Then
dteTempLast = dteLast
Else
dteTempLast = dteEnd
End If
lngNumberDays = DateValue(dteTempLast) - DateValue(dteTempFirst) + 1
fnNumberDaysStartField = dteTempLast
End Function
Public Function fnImport() As Boolean
On Error GoTo Err_fnImport
fnImport = False
Dim lngImportCounter As Long
Dim strTableName As String
lngImportCounter = 1
strTableName = fnSetTables(lngImportCounter)
Do Until strTableName = "DONE"
fnImportInto strTableName
lngImportCounter = lngImportCounter + 1
strTableName = fnSetTables(lngImportCounter)
Loop
fnConfigureTables
fnImport = True
MsgBox "Data Imported!"
Exit Function
Err_fnImport:
Select Case Err.Number
Case 70, 75, 3376
Resume Next
Case 53
Exit Function
Case Else
fnErrorHandler "fnImport"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Private Function fnImportInto(strTable As String)
On Error GoTo Err_fnImportInto
fnDeleteTable strTable
strSQL = "SELECT * " & _
"INTO " & strTable & " " & _
"FROM " & strTable & " " & _
"IN '" & strPath & "';"
dbADO.Execute strSQL
Exit Function
Err_fnImportInto:
Select Case Err.Number
Case 7874, -2147217865
Resume Next
Case Else
fnErrorHandler "fnImportInto"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnImportTableIntoArray(ArrayNumber, ExtraOne, ExtraTwo) As Long
Select Case ArrayNumber
Case 1
strSQL = "SELECT event.*, color_event.colorbackground, color_event.colortext " & _
"FROM event INNER JOIN color_event ON event.id = color_event.event;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
Do
varTableArray(1, 0, lngCounter) = rstTempADO!Id
varTableArray(1, 1, lngCounter) = rstTempADO!kurz
varTableArray(1, 2, lngCounter) = rstTempADO!lang
varTableArray(1, 3, lngCounter) = rstTempADO!ColorBackground
varTableArray(1, 4, lngCounter) = rstTempADO!ColorText
varTableArray(1, 5, lngCounter) = rstTempADO!special
varTableArray(1, 6, lngCounter) = rstTempADO!Folge
varTableArray(1, 98, lngCounter) _
= fnFindColorNumber(varTableArray(1, 3, lngCounter))
varTableArray(1, 99, lngCounter) _
= fnFindColorNumber(varTableArray(1, 4, lngCounter))
varTableArray(1, 100, lngCounter) = False 'Selected
lngCounter = lngCounter + 1
rstTempADO.MoveNext
Loop Until rstTempADO.EOF
varTableArray(1, 0, 0) = lngCounter - 1 'Array Count
Else
fnImportTableIntoArray = 0
End If
rstTempADO.Close
Case 2
strSQL = "SELECT squadrons.*, color_squadrons.colorbackground, color_squadrons.colortext " & _
"FROM color_squadrons INNER JOIN squadrons ON color_squadrons.squadrons = squadrons.id " & _
"ORDER BY squadrons.folge;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
Do
varTableArray(2, 0, lngCounter) = rstTempADO!Id
varTableArray(2, 1, lngCounter) = rstTempADO!kurz
varTableArray(2, 2, lngCounter) = rstTempADO!lang
varTableArray(2, 3, lngCounter) = rstTempADO!ColorBackground
varTableArray(2, 4, lngCounter) = rstTempADO!ColorText
varTableArray(2, 5, lngCounter) = rstTempADO!special 'sqtype
varTableArray(2, 98, lngCounter) _
= fnFindColorNumber(varTableArray(2, 3, lngCounter))
varTableArray(2, 99, lngCounter) _
= fnFindColorNumber(varTableArray(2, 4, lngCounter))
varTableArray(2, 100, lngCounter) = False 'Selected
lngCounter = lngCounter + 1
rstTempADO.MoveNext
Loop Until rstTempADO.EOF
varTableArray(2, 0, 0) = lngCounter - 1 'Array Count
Else
fnImportTableIntoArray = 0
End If
rstTempADO.Close
Case 3
strSQL = "SELECT * FROM availability " & _
"WHERE datum >= #" & ExtraOne & "# " & _
"And datum <= #" & ExtraTwo & "# " & _
"ORDER by datum;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
strSQL = ""
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
Do
varTableArray(3, 0, lngCounter) = rstTempADO!Datum
varTableArray(3, 1, lngCounter) = rstTempADO!TACCPossessedAircraft
varTableArray(3, 2, lngCounter) = rstTempADO!TACCActive
varTableArray(3, 3, lngCounter) = rstTempADO!TACCReserve
varTableArray(3, 4, lngCounter) = rstTempADO!TACCDeployedCrews
varTableArray(3, 5, lngCounter) = rstTempADO!aircraft
varTableArray(3, 6, lngCounter) = rstTempADO!CCheck
varTableArray(3, 7, lngCounter) = rstTempADO!TACCFlyableTraining
varTableArray(3, 8, lngCounter) = rstTempADO!TACCMXTraining
varTableArray(3, 9, lngCounter) = rstTempADO!MXWithhold
varTableArray(3, 10, lngCounter) = rstTempADO!TACCDeployed
varTableArray(3, 11, lngCounter) = rstTempADO!TACCTaskable
varTableArray(3, 12, lngCounter) = rstTempADO!TACCMRCrews
varTableArray(3, 13, lngCounter) = rstTempADO!LocalTrainingCrews
varTableArray(3, 14, lngCounter) = rstTempADO!LocalTrainingAircraft
varTableArray(3, 15, lngCounter) = rstTempADO!MXTraining
varTableArray(3, 16, lngCounter) = conNoChange
varTableArray(3, 17, lngCounter) = rstTempADO!reservecrewsactivated
lngCounter = lngCounter + 1
rstTempADO.MoveNext
Loop Until rstTempADO.EOF
varTableArray(3, 0, 0) = lngCounter - 1 'Array Count
fnImportTableIntoArray = lngCounter - 1
Else
fnImportTableIntoArray = 0
End If
rstTempADO.Close
Case 5
strSQL = "SELECT * FROM colors;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
strSQL = ""
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
Do
varTableArray(5, 0, lngCounter) = rstTempADO!ColorIndex
varTableArray(5, 1, lngCounter) = rstTempADO!blue
varTableArray(5, 2, lngCounter) = rstTempADO!green
varTableArray(5, 3, lngCounter) = rstTempADO!red
lngCounter = lngCounter + 1
rstTempADO.MoveNext
Loop Until rstTempADO.EOF
varTableArray(5, 0, 0) = lngCounter - 1 'Array Count
fnImportTableIntoArray = lngCounter - 1
Else
fnImportTableIntoArray = 0
End If
rstTempADO.Close
Case 6
Dim strTableName As String
lngCounter = 1
strTableName = fnSetTables(lngCounter)
Do Until strTableName = "DONE"
varTableArray(6, 0, lngCounter) = strTableName
lngCounter = lngCounter + 1
strTableName = fnSetTables(lngCounter)
Loop
varTableArray(6, 0, 0) = lngCounter - 1
Case 7
strSQL = "SELECT wing.*, color_wing.colorbackground, color_wing.colortext " & _
"FROM color_wing INNER JOIN wing ON color_wing.wing = wing.id " & _
"ORDER BY wing.folge;"
'Debug.Print strSQL
rstTempADO.Open strSQL, dbADO, adOpenStatic, adLockReadOnly
lngCounter = 1
If Not rstTempADO.EOF Then
rstTempADO.MoveFirst
Do
varTableArray(7, 0, lngCounter) = rstTempADO!Id
varTableArray(7, 1, lngCounter) = rstTempADO!kurz
varTableArray(7, 2, lngCounter) = rstTempADO!lang
varTableArray(7, 3, lngCounter) = rstTempADO!ColorBackground
varTableArray(7, 4, lngCounter) = rstTempADO!ColorText
varTableArray(7, 5, lngCounter) = rstTempADO!Folge
varTableArray(7, 98, lngCounter) _
= fnFindColorNumber(varTableArray(7, 3, lngCounter))
varTableArray(7, 99, lngCounter) _
= fnFindColorNumber(varTableArray(7, 4, lngCounter))
lngCounter = lngCounter + 1
varTableArray(7, 100, lngCounter) = False 'Selected
rstTempADO.MoveNext
Loop Until rstTempADO.EOF
varTableArray(7, 0, 0) = lngCounter - 1 'Array Count
Else
fnImportTableIntoArray = 0
End If
rstTempADO.Close
End Select
End Function
Public Function fnInsertInto(strTable)
On Error GoTo Hell
strSQL = "SELECT " & strTable & ".* " & _
"INTO " & strTable & " " & _
"IN '" & strFile & "' " & _
"FROM " & strTable & ";"
dbADO.Execute strSQL
Exit Function
Hell:
Select Case Err.Number
Case -2147217865
Resume Next
Case 91, 3704, 3420, 3240, -2147217843
fnSetDatabase
Resume
Case Else
fnErrorHandler "fnInsertInto"
MsgBox strErrorMessage
Resume Next
End Select
End Function
Public Function fnLock(obj)
obj.Locked = True
End Function
Public Function fnMostRecentUndo(Record, UndoDate) As Boolean
fnMostRecentUndo = True
If DateValue(Record!Change) > DateValue(UndoDate) Then fnMostRecentUndo = False
End Function
Public Function fnQuoteDecode(TextToBeDecoded As String) As String
TextToBeDecoded = Nz(TextToBeDecoded, "")
fnQuoteDecode = Replace(TextToBeDecoded, Chr(187) & Chr(181) & Chr(171), "'")
fnQuoteDecode = Replace(fnQuoteDecode, Chr(187) & Chr(181) & Chr(181) & Chr(171), Chr(34))
End Function
Public Function fnQuoteEncode(TextToBeEncoded) As String
TextToBeEncoded = Nz(TextToBeEncoded, "")
fnQuoteEncode = Replace(TextToBeEncoded, "'", Chr(187) & Chr(181) & Chr(171))
fnQuoteEncode = Replace(fnQuoteEncode, Chr(34), Chr(187) & Chr(181) & Chr(181) & Chr(171))
End Function
Public Function fnReadINI(strSection As String, strEntry As String) As String
Dim iLenBuf As Integer
Dim X As Long
Dim sDefault As String, sFileName As String, sRetBuf As String
sDefault = ""
sRetBuf$ = String$(256, 0) '256 null characters
iLenBuf% = Len(sRetBuf$)
sFileName = Application.CurrentProject.Path & "\" & strINIFile
X = GetPrivateProfileString(strSection, strEntry, _
sDefault, sRetBuf$, iLenBuf%, sFileName)
fnReadINI = Left$(sRetBuf$, X)
End Function
Public Function fnRecordCount(strTempSQL As String) As Long
On Error GoTo Hell
rstTempADO.Open strTempSQL, dbADO, adOpenStatic, adLockReadOnly, adCmdText
If Not rstTempADO.EOF Then
rstTempADO.MoveLast
End If
fnRecordCount = rstTempADO.RecordCount
rstTempADO.Close
Exit Function
Hell:
Select Case Err.Number
Case 91, 3420, 3240
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnRecordCount"
MsgBox strErrorMessage
End Select
End Function
Public Function fnRenumberCriteria( _
TableName As String, _
CriteriaColumn As String, _
CriteriaValue, _
OrderColumnName As String) As Long
On Error GoTo Hell
strSQL = "SELECT " & OrderColumnName & " AS ordnung " & _
"FROM " & TableName & " " & _
"WHERE (" & CriteriaColumn & " = " & CriteriaValue & ") " & _
"ORDER BY " & OrderColumnName & ";"
rstTempADO.Open strSQL, dbADO, adOpenDynamic, adLockOptimistic, adCmdText
fnRenumberCriteria = rstTempADO.RecordCount
If rstTempADO.EOF Then
rstTempADO.Close
Exit Function
Else
rstTempADO.MoveFirst
End If
lngCounter = 1
Do
rstTempADO!ordnung = lngCounter
rstTempADO.Update
rstTempADO.MoveNext
lngCounter = lngCounter + 1
Loop Until rstTempADO.EOF
rstTempADO.Close
Exit Function
Hell:
Select Case Err.Number
Case 91, 3240
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnRenumberCriteria"
MsgBox strErrorMessage
End Select
End Function
Public Function fnRenumberSimple( _
TableName As String, _
OrderColumnName As String) As Long
On Error GoTo Hell
strSQL = "SELECT " & OrderColumnName & " AS ordnung FROM " & TableName & " " & _
"ORDER BY " & OrderColumnName & ";"
rstTempADO.Open strSQL, dbADO, adOpenDynamic, adLockOptimistic, adCmdText
fnRenumberSimple = rstTempADO.RecordCount
If rstTempADO.EOF Then
rstTempADO.Close
Exit Function
Else
rstTempADO.MoveFirst
End If
lngCounter = 1
Do
rstTempADO!ordnung = lngCounter
rstTempADO.Update
rstTempADO.MoveNext
lngCounter = lngCounter + 1
Loop Until rstTempADO.EOF
rstTempADO.Close
Exit Function
Hell:
Select Case Err.Number
Case 91, 3240
fnSetDatabase
Resume
Case Else
fnErrorHandler "Main / fnRenumberSimple"
MsgBox strErrorMessage
End Select
End Function
Public Function fnReverseGreenYellowRed(xls, strField, lngMax)
With xls.Range(strField).Interior
xls.Range(strField).Select
Select Case xls.ActiveCell.Value
Case Is > 0
.ColorIndex = 35
Case "0"
.ColorIndex = 6
Case Is < 0
.ColorIndex = 3
Case Else
.ColorIndex = 0
End Select
End With
End Function
Public Function fnSelectSAMMIE() As String
fnSelectSAMMIE = "SELECT Crew.CrewText, Crew.Crew, Priority.Priority AS priorityname, " & _
"CFG.CFG AS cfgname, event.folge, Taskings.ID, taskings.event, " & _
"Taskings.Start, taskings.sq1, taskings.sq2, taskings.sq3, taskings.sq4, " & _
"taskings.ende, Taskings.Comment, Taskings.Tail, Taskings.MSN, " & _
"Taskings.wing, Taskings.FenceJet, Taskings.FrontLink, Taskings.BackLink, " & _
"Taskings.Itinerary, Taskings.Sequence, Taskings.MSNSymbolPOSDEP, " & _
"Taskings.MSNSymbolActive, Taskings.input1, Taskings.input2, Taskings.Change, " & _
"Taskings.benutzer, Taskings.PPR, Taskings.input3, Taskings.input4, " & _
"Taskings.input5, Taskings.input6, Taskings.input7, Taskings.Remark, " & _
"Taskings.input8, Taskings.CANX, Taskings.Boom, Taskings.Drogue, Taskings.Pods, " & _
"DateValue(NZ(Taskings.OriginalStart,taskings.start)) AS OriginalStart, " & _
"Nz(taskings.OriginalEnd,taskings.ende) AS OriginalEnd, Taskings.CallSign, " & _
"Taskings.MatrixRemark, Taskings.MC, Taskings.input10, Taskings.input9 " & _
"FROM Priority INNER JOIN (Crew INNER JOIN (CFG INNER JOIN (Taskings " & _
"INNER JOIN Event ON Taskings.event = Event.id) ON CFG.id = Taskings.cfg) " & _
"ON Crew.id = Taskings.crew) ON Priority.id = Taskings.priority "
End Function
Public Function fnSelectTaskings(lngID) As String
fnSelectTaskings = "SELECT * FROM Taskings " & _
"WHERE id = " & Trim(Str(lngID)) & ";"
End Function
Public Function fnSelectInUseID(lngID) As String
fnSelectInUseID = "SELECT * FROM InUse " & _
"WHERE ID = " & Trim(Str(lngID)) & ";"
End Function
Public Function fnSelectInUseUsername(strUsername) As String
fnSelectInUseUsername = "SELECT * FROM InUse " & _
"WHERE benutzer =" & Chr(34) & strUsername & Chr(34) & ";"
End Function
Public Function fnSetDatabase() As Boolean
fnSetDatabase = False
strBenutzer = fnGetUsername
strRootFolder = fnGetSpecialFolderA(CSIDL_PERSONAL)
fnImportTableIntoArray 6, Null, Null
fnOpenADOConnection
If fnFindMaxID("patch") = 12 Then
'V3.33
fnPatch013
End If
If fnFindMaxID("patch") = 13 Then
'V3.34
fnPatch014
End If
lngNullValues.CFG = fnFindRecordID("SELECT * FROM cfg;", "kurz", "Null")
lngNullValues.Crew = fnFindRecordID("SELECT * FROM crew;", "crew", "Null")
fnImportTableIntoArray 1, Null, Null
'Folge=1 is the default Event
lngTemp = fnFindIDinArray(1, 6, 1)
lngNullValues.Event = varTableArray(1, 0, lngTemp)
lngNullValues.EventType = fnFindRecordID("SELECT * FROM eventtype;", "kurz", "Null")
lngNullValues.Priority = fnFindRecordID("SELECT * FROM priority;", "priority", "Null")
lngNullValues.SQType _
= fnFindRecordID("SELECT * FROM sqtype;", "sqtype", "'" & "None" & "'")
lngNullValues.Squadrons(0) = fnFindRecordID("SELECT * FROM squadrons;", "kurz", "Null")
lngNullValues.Squadrons(1) = _
fnFindRecordID("SELECT * FROM squadrons;", "kurz", "'" & "UA" & "'")
fnImportTableIntoArray 7, Null, Null
lngTemp = fnFindIDinArray(7, 1, Null)
lngNullValues.Wing(0) = varTableArray(7, 0, lngTemp)
'Folge = 2 is the Other Wing
lngTemp = fnFindIDinArray(7, 3, 2)
lngNullValues.Wing(1) = varTableArray(7, 0, lngTemp)
fnLoadConstants
fnLoadconEvent
fnCreateDirectory strRootFolder, Constant.DocumentFolder
strTemp = Left(Right(Application.CurrentProject.Name, 7), 3)
strProgramVersion = "Version " & Left(strTemp, 1) & "." & Right(strTemp, 2)
' strProgramVersion = "Version 3.50"
fnWriteINI "Program", "Logon", Val(fnReadINI("Program", "Logon")) + 1
fnWriteINI fnCurrentMachineName, "User", fnGetUsername & " Online " & strProgramVersion
fnWriteINI fnCurrentMachineName, "Logon", Val(fnReadINI(fnCurrentMachineName, "Logon")) + 1
fnSetDatabase = True
End Function
Private Function fnBackupInto(TableName)
fnInsertInto TableName
End Function
Public Function fnChangeButtonColor(ctl, strID, lngColor)
If strID <> "" Then
ctl.ForeColor = lngColor
End If
End Function
Public Function fnSetTables(TableCounter As Long) As String
Select Case TableCounter
Case 1
fnSetTables = "availability"
Case 2
fnSetTables = "cfg"
Case 3
fnSetTables = "colors"
Case 4
fnSetTables = "constants"
Case 5
fnSetTables = "crew"
Case 6
fnSetTables = "dates"
Case 7
fnSetTables = "event"
Case 8
fnSetTables = "inuse"
Case 9
fnSetTables = "msn"
Case 10
fnSetTables = "priority"
Case 11
fnSetTables = "sqtype"
Case 12
fnSetTables = "taskings"
Case 13
fnSetTables = "eventtype"
Case 14
fnSetTables = "squadrons"
Case 15
fnSetTables = "defaults"
Case 16
fnSetTables = "patch"
Case 17
fnSetTables = "buttons"
Case 18
fnSetTables = "wing"
Case 19
fnSetTables = "color_event"
Case 20
fnSetTables = "color_squadrons"
Case 21
fnSetTables = "color_wing"
Case 22
fnSetTables = "DONE"
End Select
End Function
Public Function fnToggleForeColor(ctl, lngColor)
If ctl Then
ctl.ForeColor = lngColor
Else
ctl.ForeColor = 0
End If
End Function
Public Function fnUnLock(obj)
obj.Locked = False
End Function
Public Function fnUnlockInUse()
On Error GoTo Err_fnUnlockInUse
If blnSquadron Then Exit Function
strSQL = "DELETE InUse.* FROM InUse;"
dbADO.Execute strSQL
Exit Function
Err_fnUnlockInUse:
Select Case Err.Number
Case 3078
Exit Function
Case Else
fnErrorHandler "fnUnlockInUse"
MsgBox strErrorMessage
End Select
End Function
Public Function fnUpdateRecord( _
TableName As String, _
FieldName As String, _
FromValue, _
ToValue)
Dim strSQL As String
strSQL = "UPDATE " & TableName & " SET " & FieldName & " = " & ToValue & " " & _
"WHERE " & FieldName & "=" & FromValue & ";"
dbADO.Execute strSQL
End Function
Public Function fnUpDownButtonConfiguration( _
Liste As ListBox, _
DownButton As CommandButton, _
UpButton As CommandButton, _
Folge As Long, _
ListCountAdjustment As Long, _
TableCountAdjustment As Long, _
RowsToIgnore As Long, _
Form As Form)
fnCheckSession Form.Name
Liste.SetFocus
If Folge = 0 Or Liste.ListCount - ListCountAdjustment <= 1 _
Or Folge - TableCountAdjustment = RowsToIgnore Then
UpButton.Enabled = False
DownButton.Enabled = False
ElseIf Folge - TableCountAdjustment - RowsToIgnore = 1 _
And Liste.ListCount - ListCountAdjustment > 1 + RowsToIgnore Then
UpButton.Enabled = False
DownButton.Enabled = True
ElseIf Liste.ListCount - ListCountAdjustment > 1 + RowsToIgnore _
And Folge - TableCountAdjustment = Liste.ListCount - ListCountAdjustment Then
UpButton.Enabled = True
DownButton.Enabled = False
Else
UpButton.Enabled = True
DownButton.Enabled = True
End If
End Function
Public Function fnVisible(obj)
obj.Visible = True
End Function
Public Function fnWriteINI(strSection, strEntry$, strData$)
Dim sFileName As String
sFileName$ = Application.CurrentProject.Path & "\" & strINIFile
WritePrivateProfileString strSection, strEntry$, strData$, sFileName$
End Function"
Last Comment
Scott McDaniel (EE MVE )
That is a MASSIVE amount of code, and I'm not going to look through it to find the right line. Can you let us know which line errors out?
ASKER
Line 1370 is where it errors out. Thanks.
At first glance, I'd think that the "strField" does not reference a field in the recordset. Without knowing the values you're passing in for strRecord, strField, etc, however, that's hard to say.
Can you set a breakpoint in the code (line 1363, perhaps) and then show what the values of your variables are?
Note too that it seems a bit redundant to open a recordset and then filter it. You could instead just open a filtered recordset:
rstTablesADO.Open strRecord & " WHERE " & strField & "=" & LookFor, dbADO, adOpenStatic, adLockReadOnly
If Not (rstTablesADO.EOF and rstTableADO.BOF) Then
'/ you found a record
End If
Of course, your code (or mine above) would fail if the value you're searching for is a Text value, or a Date value. Your code doesn't seem to check for that.
Can you set a breakpoint in the code (line 1363, perhaps) and then show what the values of your variables are?
Note too that it seems a bit redundant to open a recordset and then filter it. You could instead just open a filtered recordset:
rstTablesADO.Open strRecord & " WHERE " & strField & "=" & LookFor, dbADO, adOpenStatic, adLockReadOnly
If Not (rstTablesADO.EOF and rstTableADO.BOF) Then
'/ you found a record
End If
Of course, your code (or mine above) would fail if the value you're searching for is a Text value, or a Date value. Your code doesn't seem to check for that.
SOLUTION
THIS SOLUTION IS ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
ASKER CERTIFIED SOLUTION
THIS SOLUTION IS ONLY AVAILABLE TO MEMBERS.
View this solution by signing up for a free trial.
Members can start a 7-Day free trial and enjoy unlimited access to the platform.
For the search string, I recommend using a strSearch variable, which you can then display in the Immediate Window for purposes of debugging. strSearch = strField & " = " & LookFor
Then Debug.Print "Search string: " & strSearch
One possible cause of errors in search string is data typing -- you may have to do some data type conversion to yield a valid string.
Then Debug.Print "Search string: " & strSearch
One possible cause of errors in search string is data typing -- you may have to do some data type conversion to yield a valid string.
No response from author
Microsoft Access
Microsoft Access is a rapid application development (RAD) relational database tool. Access can be used for both desktop and web-based applications, and uses VBA (Visual Basic for Applications) as its coding language.
226K
Questions
--
Followers
--
Top Experts
Get a personalized solution from industry experts
TRUSTED BY
