R
RNUSZ@OKDPS
Can someone find my problem! This code dies the .UPDATE statement in
function called SUBLOAD-RC20RW-NAMES20. Error # 3265 with error description
of "Item Not Found In This Collection!". I need to read from table A,
(first record, then separate data from record A into possibly 3 name/address
records to table D. then, loop back through table A, and repeat the process
until no more names in table A. Any suggestions... Thanks in advance.
Option Compare Database
'The form is used by the Legal System / Financial Responsibilites
Application. It
'is used as a Application Menu that allows the user to select the type
of Report Run
'to be requested: Hearing Letters, Cancellation Letters, or Findings
Letters.
'The code was last revised: 05/09/2005
'Developed on Microsoft Access 2003 Professional By Robert E. Nusz
'Application Support, Department of Public Safety, State of Oklahoma
Private Sub Combo13_Click()
Dim intThisRun As Integer 'used to identify type of run, 10, 13, 20
Dim strSQL As String 'used to hold SQL string for Alter Table
command
Dim lngRecCount As Integer ' Define Table Record Counter
'*******************************************************************************************
'** Code to Create Hearing Letters - User Option 10
**
'*******************************************************************************************
'*******************************************************************************************
'** Code to Create Finding-Of-Fact Letters - User Option 20
**
'*******************************************************************************************
If Combo13 = 20 Then
'MsgBox " Prepare to Create Finding-Of-Fact Letters ! "
' The following Macro creates DPS_FRQ_RC20RW temporary table
DoCmd.runMacro "FRM-RC20RW"
' The following statement builds the Primary Key field for
DPS_FRQ_RC20RW table
strSQL = "ALTER TABLE DPS_FRQ_RC20RW " & _
"ADD CONSTRAINT PK_RC20RW " & _
"PRIMARY KEY(Case_Num_Yr,Case_Num)"
CurrentDb.Execute strSQL, dbFailOnError
' Determine if there are records extracted, (20's) to report on
lngRecCount = fncRecordsInTableInt("DPS_FRQ_RC20RW", "PRTNO_NUM", 20)
'MsgBox " Code 20 Records In Table Found Number: " & lngRecCount
If lngRecCount <> 0 Then
intThisRun = 20
'create envelope / label data table here for code 20s
Else
' set RC=99 to indicate no Code 20's selected in this run
intThisRun = 99
End If
'*******************************************************************************************
'** Code for Case 10 - CASE HEARING LETTERS
**
'*******************************************************************************************
Select Case intThisRun
Case 10
' do this.....
'***********************************************************************
'** Code for Case 13 - CASE CANCELLATION LETTERS
**
'***********************************************************************
Case 13
' do this
'***********************************************************************
'** Code for Case 20 - CASE FINDING-OF-FACT LETTERS
**
'**********************************************************************
Case 20
' CHECK TO SEE IF THE USER WANTS TO PRINT CASE FINDINGS LETTERS
NOW!
Returnval = MsgBox("Do You Wish To Print" & Chr$(10) & "Case
Findings Letters Now", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
Returnval = MsgBox(" Are Legal Letterhead Forms" & Chr$(10)
& " Currently In Printer", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
'DoCmd.OpenReport "FRR-CaseLHFindings", acViewPreView
'MsgBox " Now Printing Case Findings Letters "
' the following statement prints ACTIVE (20's)
Finding-Of-Fact Letters
fncPrintFindingLetters
' following statement creates DPS_FR_RC20RW_NAMES20
temporary table
If fncTableExists("DPS_FR_RC20RW_NAMES20") = True Then
MsgBox " DPS_FR_RC20RW_NAMES Table Does Exist "
' DPS_FR_RC20RW Table Exists then
If DCount("*", "DPS_FR_RC20RW_NAMES20") <> 0 Then
MsgBox " Now Deleting Existing
DPS_FR_RC20RW_NAMES20 Records "
' DPS_FR_RC20RW_NAMES20 has existing records,
so delete them
strSQL = "DELETE * FROM DPS_FR_RC20RW_NAMES20"
CurrentDb.Execute strSQL, dbFailOnError
'Load Records to DPS_FR_RC20RW_NAMES20 Now
MsgBox " Now Loading DPS_FR_RC20RW_NAMES20
Records 1 "
Call subLoad_RC20RW_NAMES20
Else
MsgBox " DPS_FR_RC20RW_NAMES Table Does
Exist, with NO Records "
'Load Records To DPS_FR_RC20RW_NAMES20 Now
MsgBox " Now Loading DPS_FR_RC20RW_NAMES20
Records 2 "
Call subLoad_RC20RW_NAMES20
End If
Else
MsgBox " DPS_FR_RC20RW_NAMES Table Did Not Exist "
' following statement Creates
DPS_FR_RC20RW_NAMES20 Table
fncCreateName20Table
'Load Records To DPS_FR_RC20RW_NAMES20 Now
MsgBox " Now Loading DPS_FR_RC20RW_NAMES20
Records 3 "
Call subLoad_RC20RW_NAMES20
End If
lngRecCount =
fncRecordsInTableInt("DPS_FR_RC20RW_NAMES20", "PRTNO_NUM", 20)
MsgBox " DPS_FR_RC20RW_NAMES20 record count = " &
lngRecCount
End If
End If
' CHECK TO SEE IF THE USER WANTS TO PRINT CASE EVELOPES NOW!
Returnval = MsgBox("Do You Wish To Print" & Chr$(10) & "Case
Envelopes Now", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
Returnval = MsgBox(" Are Envelope Forms" & Chr$(10) & "
Currently In Printer", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
'DoCmd.OpenReport "FRR-CaseEnvelope", acViewPreView
MsgBox " Now Printing Case Envelopes "
End If
End If
Case Else
MsgBox " No Letters Selected, RC=99 ", vbExclamation
End Select
Exit Sub
End Sub
Private Sub Command9_Return_Click()
On Error GoTo Err_Command9_Return_Click
'When clicked, this button will redirect the user back to form
FRF-Main-Menu
DoCmd.Close
Exit_Command9_Return_Click:
Exit Sub
Err_Command9_Return_Click:
MsgBox Err.Description
Resume Exit_Command9_Return_Click
End Sub
Function fncRecordsInTableInt(Tablename As String, Fieldname As String,
FieldValue As Integer) As Long
' Function is used to count the number of records in requested table and
pass that
' record count back to calling code to determine if records are
available to process
Dim rstRecInTableI As DAO.Recordset
Dim strSQL As String
Dim strTableField As String
Dim strFieldValue As Integer
strFieldValue = FieldValue
strTableField = Tablename & "." & Fieldname
strSQL = "SELECT Count(" & strTableField & ") AS [Count] From " &
Tablename & _
" WHERE " & strTableField & " = " & strFieldValue & ";"
Set rstRecInTableI = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
fncRecordsInTableInt = rstRecInTableI!Count
rstRecInTableI.Close
Set rstRecInTableI = Nothing
End Function
Function fncTableExists(strTable As String) As Boolean
On Error GoTo TableExistsError
'This function will check to see if a table exists in current database
Dim db As DAO.Database
Dim doc As DAO.Document
Set db = CurrentDb()
With db.Containers!Tables
For Each doc In .Documents
If doc.NAME = strTable Then
fncTableExists = True
Exit For
End If
Next doc
End With
ExitPoint:
'Cleanup vbCode
On Error Resume Next
db.Close
Set db = Nothing
Exit Function
TableExistsError:
' This function encountered unexpected error
MsgBox " The following Error Has Occurred: " _
& vbNewLine & "Error Number: " & Err.Number _
& vbNewLine & " Error Description: " & Err.Description _
, vbExlamation, " Unexpected Error "
Resume ExitPoint
End Function
Function fncPrintFindingLetters()
Dim rstRCFL As ADODB.Recordset
Set rstRCFL = New ADODB.Recordset
'Establish the connection, cursor type, and open the recordset
rstRCFL.ActiveConnection = CurrentProject.Connection
rstRCFL.CursorType = adOpenForwardOnly
rstRCFL.Open "Select * from DPS_FRQ_RC20RW"
'Print Proper Finding Letter Based on RESULT_CDE Value
'Loop through until EOF
Dim intCaseNumYr1 As Integer
Dim intCaseNum1 As Integer
Dim strCriteria1 As String
Dim strReportName1 As String
Dim strBadRecordKey1 As String
If Not rstRCFL.BOF Then
rstRCFL.MoveFirst
Do Until rstRCFL.EOF
If rstRCFL![RESULT_CDE] = "11" Then
strReportName1 = "FRR-FOFRC11"
intCaseNumYr1 = rstRCFL![CASE_NUM_YR]
intCaseNum1 = rstRCFL![CASE_NUM]
strCriteria1 = "[FRQ-FOFPC20]![CASE_NUM_YR] = " &
intCaseNumYr1 & _
" AND [FRQ-FOFPC20]![CASE_NUM] = " & intCaseNum1
'Print current Record to form FRR-FOFRC11 1 Copy
'DoCmd.OpenReport strReportName1, acViewPreview, ,
strCriteria1
' The following 5 lines of VB code work to open WORD and
Template file,
' but the software fails to allow proper edit controls of
names & data values
' therefore it is not being used at this time, but do not
erase code....
'Dim oApp As Object
'Set oApp = CreateObject("Word.Application")
'oApp.Visible = True
'oApp.Documents.Add "c:\My Access Test.doc"
'DoCmd.Close acForm, "FrmBlank"
ElseIf rstRCFL![RESULT_CDE] > "49" And _
rstRCFL![RESULT_CDE] < "60" Then
'MBox " Like 5xxx " & rstRCFL![RESULT_CDE]
strReportName1 = "FRR-FOFRC5x"
intCaseNumYr1 = rstRCFL![CASE_NUM_YR]
intCaseNum1 = rstRCFL![CASE_NUM]
strCriteria1 = "[FRQ-FOFPC20]![CASE_NUM_YR] = " &
intCaseNumYr1 & _
" AND [FRQ-FOFPC20]![CASE_NUM] = " & intCaseNum1
'MsgBox " Printing 5xxx " & rstRCFL![RESULT_CDE]
'DoCmd.OpenReport strReportName1, acViewPreview, ,
strCriteria1
Else
MsgBox " Invalid Result Code Found In Followng Record"
strBadRecordKey1 = rstRCFL![CASE_NUM_YR] & " " &
rstRCFL![CASE_NUM] & " " & rstRCFL![RESULT_CDE]
MsgBox strBadRecordKey1
End If
rstRCFL.MoveNext
Loop
End If
rstRCFL.Close
Set rstRCFL = Nothing
End Function
Function fncCreateName20Table()
MsgBox " Now Creating DPS_FR_RC20RW_NAMES20 Table "
' This statement Defines the Table named NAMES20
Dim NewTbl As TableDef
Set NewTbl = CurrentDb.CreateTableDef("DPS_FR_RC20RW_NAMES20")
Dim fld1 As Field ' for CASE_NUM_YR
Dim fld2 As Field ' for CASE_NUM
Dim fld3 As Field ' for SEQNO_NUM
Dim fld4 As Field ' for PRTNO_NUM
Dim fld5 As Field ' for NAME_TXT
Dim fld6 As Field ' for FIRM_TXT
Dim fld7 As Field ' for ADDR1_TXT
Dim fld8 As Field ' for ADDR2_TXT
Dim fld9 As Field ' for CITY_TXT
Dim fld10 As Field ' for STATE_CDE
Dim fld11 As Field ' for ZIPCDE_TXT
Set fld1 = NewTbl.CreateField("CASE_NUM_YR", dbLong)
fld1.Required = True
Set fld2 = NewTbl.CreateField("CASE_NUM", dbLong)
fld2.Required = True
Set fld3 = NewTbl.CreateField("SEQNO_NUM", dbLong)
fld3.Required = True
'fld3.Attributes = fld3.Attributes + dbAutoIncrField
Set fld4 = NewTbl.CreateField("PRTNO_NUM", dbLong)
fld4.Required = True
Set fld5 = NewTbl.CreateField("NAME_TXT", dbText, 50)
fld5.Required = True
Set fld6 = NewTbl.CreateField("FIRM_TXT", dbText, 50)
fld6.AllowZeroLength = True
Set fld7 = NewTbl.CreateField("ADDR1_TXT", dbText, 30)
fld7.Required = True
Set fld8 = NewTbl.CreateField("ADDR2_TXT", dbText, 30)
fld8.AllowZeroLength = True
Set fld9 = NewTbl.CreateField("CITY_TXT", dbText, 30)
fld9.Required = True
Set fld10 = NewTbl.CreateField("STATE_CDE", dbText, 2)
fld10.Required = True
Set fld11 = NewTbl.CreateField("ZIPCDE_TXT", dbText, 10)
fld11.AllowZeroLength = True
NewTbl.Fields.Append fld1
NewTbl.Fields.Append fld2
NewTbl.Fields.Append fld3
NewTbl.Fields.Append fld4
NewTbl.Fields.Append fld5
NewTbl.Fields.Append fld6
NewTbl.Fields.Append fld7
NewTbl.Fields.Append fld8
NewTbl.Fields.Append fld9
NewTbl.Fields.Append fld10
NewTbl.Fields.Append fld11
CurrentDb.TableDefs.Append NewTbl
strSQL = "ALTER TABLE DPS_FR_RC20RW_NAMES20 " & _
"ADD CONSTRAINT PK_NAMES20 " & _
"PRIMARY KEY(Case_Num_Yr,Case_Num)"
CurrentDb.Execute strSQL, dbFailOnError
MsgBox " Successfully Created DPS_FR_RC20RW_NAMES20 Table "
End Function
Public Sub subLoad_RC20RW_NAMES20()
On Error GoTo Error_Load_RC20RW_NAMES20
' Insert code to build new names20 records here...
MsgBox " Now entering subLoad_RC20RW_NAMES20 "
Dim rsA As Recordset
Dim rsB As Recordset
Dim rsD As DAO.Recordset
Dim intSelectAtty As Integer
Dim intHoldCaseNumYr As Integer
Dim intHoldCaseNum As Integer
Dim intHoldPrtNoNum As Integer
Dim intSeqNo As Integer
intSeqNo = 0
MsgBox " Now opening rsA "
Set rsA = CurrentDb.OpenRecordset("DPS_FRQ_RC20RW")
MsgBox " Now opening rsB "
Set rsB = CurrentDb.OpenRecordset("DPS_FR_ATTORNEY")
MsgBox " Now opening rsD "
Set rsD = CurrentDb.OpenRecordset("DPS_FR_RC20RW_NAMES20")
If Not (rsA.BOF And rsA.EOF) Then
MsgBox " rsA.BOF and rsA.EOF = " & rsA.BOF & " " & rsA.EOF
rsA.MoveFirst
Do Until rsA.EOF
With rsD
While Not rsA.EOF
'****************************************************************************************
'* If Licensee not null, add Licensee Name, Address, City, State to Table D
*
'****************************************************************************************
If Not IsNull(rsA![LIC_FIRST_NME]) Then
MsgBox " Adding Record = " & rsA![CASE_NUM_YR] & " " & _
rsA![CASE_NUM] & " " & rsA![LIC_LAST_NME]
.AddNew
intHoldCaseNumYr = rsA![CASE_NUM_YR]
intHoldCaseNum = rsA![CASE_NUM]
intHoldPrtNoNum = rsA![PRTNO_NUM]
MsgBox " intHoldCaseNumYr 1 = " & intHoldCaseNumYr
MsgBox " intHoldCaseNum 1 = " & intHoldCaseNum
MsgBox " intHoldPrtNoNum 1 = " & intHoldPrtNoNum
![CASE_NUM_YR] = intHoldCaseNumYr ' build primary
key pt-1
![CASE_NUM] = intHoldCaseNum ' build primary
key pt-2
![SEQNO_NUM] = intSeqNo + 1
![PRTNO_NUM] = intHoldPrtNoNum ' build PRTNO_NUM
![NAME_TXT] = rsA![LIC_FIRST_NME] & " " & _
rsA![LIC_MIDDLE_NME] & " " & _
rsA![LIC_LAST_NME] & " " & _
rsA![LIC_SUBT_TXT]
![FIRM_TXT] = rsA![LIC_LAST_NME]
![ADDR1_TXT] = rsA![LIC_ADDR_TXT]
![ADDR2_TXT] = rsA![LIC_ADDR_TXT]
![CITY_TXT] = rsA![LIC_CITY_NME]
![STATE_CDE] = rsA![LIC_STATE_CDE]
![ZIPCDE_TXT] = rsA![LIC_ZIP_CDE] & " " &
rsA![LIC_ZIP4_CDE]
MsgBox " NAME_TXT 1 = " & rsA!NAME_TXT
.Update
End If
'***********************************************************************
'* If DOA_NME not null, add DOA Name, Address, City, State to Table D
*
'***********************************************************************
If Not IsNull(rsA![DOA_NME]) Then
MsgBox " Adding Record 2 = " & rsA![CASE_NUM_YR] & " " & _
rsA![CASE_NUM] & " " & rsA![DOA_NME]
.AddNew
MsgBox " intHoldCaseNumYr 2 = " & intHoldCaseNumYr
MsgBox " intHoldCaseNum 2 = " & intHoldCaseNum
MsgBox " intHoldPrtNoNum 2 = " & intHoldPrtNoNum
![CASE_NUM_YR] = intHoldCaseNumYr ' build primary
key pt-1
![CASE_NUM] = intHoldCaseNum ' build primary
key pt-2
![SEQNO_NUM] = intSeqNo + 1
![PRTNO_NUM] = intHoldPrtNoNum ' build PRTNO_NUM
![NAME_TXT] = rsA![DOA_NME]
![FIRM_TXT] = Null
![ADDR1_TXT] = rsA![DOA_ADDR_TXT]
![ADDR2_TXT] = Null
![CITY_TXT] = rsA![DOA_CITY_NME]
![STATE_CDE] = rsA![DOA_STATE_CDE]
![ZIP_CDE] = rsA![LIC_ZIP_CDE] & " " & rsA![LIC_ZIP4_CDE]
MsgBox " NAME_TXT 2 = " & rsA![DOA_NME]
.Update
End If
'***********************************************************************
'* If Attorney <> 0, add Attorney Name, Address, City, State to Table D
*
'***********************************************************************
If rsA![ATTY_NUM] <> 0 Then
'select attorney record via sql statement
intSelectAtty = rsA![ATTY_NUM]
MsgBox " Select Attorney # = " & intSelectAtty
DoCmd.runMacro "FRM-Atty-FOF-Select"
If Not (rsB.BOF And rsB.EOF) Then
rsB.MoveFirst
If Not rsB.EOF Then
MsgBox " Adding Record = " & rsA![CASE_NUM_YR] &
" " & _
rsA![CASE_NUM] & " " & rsB![LAST_NME]
MsgBox " intHoldCaseNumYr 3 = " & intHoldCaseNumYr
MsgBox " intHoldCaseNum 3 = " & intHoldCaseNum
MsgBox " intHoldPrtNoNum 3 = " & intHoldPrtNoNum
.AddNew
![CASE_NUM_YR] = intHoldCaseNumYr ' build
pkey pt-1
![CASE_NUM] = intHoldCaseNum ' build
pkey pt-2
![SEQNO_NUM] = intSeqNo + 1
![PRTNO_NUM] = intHoldPrtNoNum ' build
PRTNO_NUM
![NAME_TXT] = rsB![FIRST_NME] & " " & _
rsB![MIDDLE_NME] & " " & _
rsB![LAST_NME] & " " & _
rsB![SUBTITLE_TXT]
![FIRM_NME] = rsB![FIRM_NME]
![ADDR1_TXT] = rsB![ADDR1_TXT]
![ADDR2_TXT] = rsB![ADDR2_TXT]
![CITY_TXT] = rsB![CITY_NME]
![STATE_CDE] = rsB![STATE_CDE]
![ZIP_CDE] = rsB![LIC_ZIP_CDE] & " " &
rsB![LIC_ZIP4_CDE]
MsgBox " NAME_TXT 3 = " & rsB![FIRST_NME]
.Update
End If
End If
End If
rsA.MoveNext
Wend
End With
Loop
End If
rsA.Close
rsB.Close
rsD.Close
Set rsA = Nothing
Set rsB = Nothing
Set rsD = Nothing
Exit_Load_RC20RW_NAMES20:
' Cleanup Code
On Error Resume Next
Exit Sub
Error_Load_RC20RW_NAMES20:
Select Case Err.Number
Case 2501
' Action Cancelled by User, Ignore Error
Case Else
' Unexpected Error Encountered
MsgBox " The following error has occurred: " _
& vbNewLine & " Error Number: " & Err.Number _
& vbNewLine & "Error Description: " & Err.Description _
, vbExclamation, " Unexpected Error "
End Select
Resume Exit_Load_RC20RW_NAMES20
End Sub
function called SUBLOAD-RC20RW-NAMES20. Error # 3265 with error description
of "Item Not Found In This Collection!". I need to read from table A,
(first record, then separate data from record A into possibly 3 name/address
records to table D. then, loop back through table A, and repeat the process
until no more names in table A. Any suggestions... Thanks in advance.
Option Compare Database
'The form is used by the Legal System / Financial Responsibilites
Application. It
'is used as a Application Menu that allows the user to select the type
of Report Run
'to be requested: Hearing Letters, Cancellation Letters, or Findings
Letters.
'The code was last revised: 05/09/2005
'Developed on Microsoft Access 2003 Professional By Robert E. Nusz
'Application Support, Department of Public Safety, State of Oklahoma
Private Sub Combo13_Click()
Dim intThisRun As Integer 'used to identify type of run, 10, 13, 20
Dim strSQL As String 'used to hold SQL string for Alter Table
command
Dim lngRecCount As Integer ' Define Table Record Counter
'*******************************************************************************************
'** Code to Create Hearing Letters - User Option 10
**
'*******************************************************************************************
'*******************************************************************************************
'** Code to Create Finding-Of-Fact Letters - User Option 20
**
'*******************************************************************************************
If Combo13 = 20 Then
'MsgBox " Prepare to Create Finding-Of-Fact Letters ! "
' The following Macro creates DPS_FRQ_RC20RW temporary table
DoCmd.runMacro "FRM-RC20RW"
' The following statement builds the Primary Key field for
DPS_FRQ_RC20RW table
strSQL = "ALTER TABLE DPS_FRQ_RC20RW " & _
"ADD CONSTRAINT PK_RC20RW " & _
"PRIMARY KEY(Case_Num_Yr,Case_Num)"
CurrentDb.Execute strSQL, dbFailOnError
' Determine if there are records extracted, (20's) to report on
lngRecCount = fncRecordsInTableInt("DPS_FRQ_RC20RW", "PRTNO_NUM", 20)
'MsgBox " Code 20 Records In Table Found Number: " & lngRecCount
If lngRecCount <> 0 Then
intThisRun = 20
'create envelope / label data table here for code 20s
Else
' set RC=99 to indicate no Code 20's selected in this run
intThisRun = 99
End If
'*******************************************************************************************
'** Code for Case 10 - CASE HEARING LETTERS
**
'*******************************************************************************************
Select Case intThisRun
Case 10
' do this.....
'***********************************************************************
'** Code for Case 13 - CASE CANCELLATION LETTERS
**
'***********************************************************************
Case 13
' do this
'***********************************************************************
'** Code for Case 20 - CASE FINDING-OF-FACT LETTERS
**
'**********************************************************************
Case 20
' CHECK TO SEE IF THE USER WANTS TO PRINT CASE FINDINGS LETTERS
NOW!
Returnval = MsgBox("Do You Wish To Print" & Chr$(10) & "Case
Findings Letters Now", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
Returnval = MsgBox(" Are Legal Letterhead Forms" & Chr$(10)
& " Currently In Printer", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
'DoCmd.OpenReport "FRR-CaseLHFindings", acViewPreView
'MsgBox " Now Printing Case Findings Letters "
' the following statement prints ACTIVE (20's)
Finding-Of-Fact Letters
fncPrintFindingLetters
' following statement creates DPS_FR_RC20RW_NAMES20
temporary table
If fncTableExists("DPS_FR_RC20RW_NAMES20") = True Then
MsgBox " DPS_FR_RC20RW_NAMES Table Does Exist "
' DPS_FR_RC20RW Table Exists then
If DCount("*", "DPS_FR_RC20RW_NAMES20") <> 0 Then
MsgBox " Now Deleting Existing
DPS_FR_RC20RW_NAMES20 Records "
' DPS_FR_RC20RW_NAMES20 has existing records,
so delete them
strSQL = "DELETE * FROM DPS_FR_RC20RW_NAMES20"
CurrentDb.Execute strSQL, dbFailOnError
'Load Records to DPS_FR_RC20RW_NAMES20 Now
MsgBox " Now Loading DPS_FR_RC20RW_NAMES20
Records 1 "
Call subLoad_RC20RW_NAMES20
Else
MsgBox " DPS_FR_RC20RW_NAMES Table Does
Exist, with NO Records "
'Load Records To DPS_FR_RC20RW_NAMES20 Now
MsgBox " Now Loading DPS_FR_RC20RW_NAMES20
Records 2 "
Call subLoad_RC20RW_NAMES20
End If
Else
MsgBox " DPS_FR_RC20RW_NAMES Table Did Not Exist "
' following statement Creates
DPS_FR_RC20RW_NAMES20 Table
fncCreateName20Table
'Load Records To DPS_FR_RC20RW_NAMES20 Now
MsgBox " Now Loading DPS_FR_RC20RW_NAMES20
Records 3 "
Call subLoad_RC20RW_NAMES20
End If
lngRecCount =
fncRecordsInTableInt("DPS_FR_RC20RW_NAMES20", "PRTNO_NUM", 20)
MsgBox " DPS_FR_RC20RW_NAMES20 record count = " &
lngRecCount
End If
End If
' CHECK TO SEE IF THE USER WANTS TO PRINT CASE EVELOPES NOW!
Returnval = MsgBox("Do You Wish To Print" & Chr$(10) & "Case
Envelopes Now", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
Returnval = MsgBox(" Are Envelope Forms" & Chr$(10) & "
Currently In Printer", _
vbQuestion + vbYesNo)
If Returnval = 6 Then
'DoCmd.OpenReport "FRR-CaseEnvelope", acViewPreView
MsgBox " Now Printing Case Envelopes "
End If
End If
Case Else
MsgBox " No Letters Selected, RC=99 ", vbExclamation
End Select
Exit Sub
End Sub
Private Sub Command9_Return_Click()
On Error GoTo Err_Command9_Return_Click
'When clicked, this button will redirect the user back to form
FRF-Main-Menu
DoCmd.Close
Exit_Command9_Return_Click:
Exit Sub
Err_Command9_Return_Click:
MsgBox Err.Description
Resume Exit_Command9_Return_Click
End Sub
Function fncRecordsInTableInt(Tablename As String, Fieldname As String,
FieldValue As Integer) As Long
' Function is used to count the number of records in requested table and
pass that
' record count back to calling code to determine if records are
available to process
Dim rstRecInTableI As DAO.Recordset
Dim strSQL As String
Dim strTableField As String
Dim strFieldValue As Integer
strFieldValue = FieldValue
strTableField = Tablename & "." & Fieldname
strSQL = "SELECT Count(" & strTableField & ") AS [Count] From " &
Tablename & _
" WHERE " & strTableField & " = " & strFieldValue & ";"
Set rstRecInTableI = CurrentDb.OpenRecordset(strSQL, dbOpenSnapshot)
fncRecordsInTableInt = rstRecInTableI!Count
rstRecInTableI.Close
Set rstRecInTableI = Nothing
End Function
Function fncTableExists(strTable As String) As Boolean
On Error GoTo TableExistsError
'This function will check to see if a table exists in current database
Dim db As DAO.Database
Dim doc As DAO.Document
Set db = CurrentDb()
With db.Containers!Tables
For Each doc In .Documents
If doc.NAME = strTable Then
fncTableExists = True
Exit For
End If
Next doc
End With
ExitPoint:
'Cleanup vbCode
On Error Resume Next
db.Close
Set db = Nothing
Exit Function
TableExistsError:
' This function encountered unexpected error
MsgBox " The following Error Has Occurred: " _
& vbNewLine & "Error Number: " & Err.Number _
& vbNewLine & " Error Description: " & Err.Description _
, vbExlamation, " Unexpected Error "
Resume ExitPoint
End Function
Function fncPrintFindingLetters()
Dim rstRCFL As ADODB.Recordset
Set rstRCFL = New ADODB.Recordset
'Establish the connection, cursor type, and open the recordset
rstRCFL.ActiveConnection = CurrentProject.Connection
rstRCFL.CursorType = adOpenForwardOnly
rstRCFL.Open "Select * from DPS_FRQ_RC20RW"
'Print Proper Finding Letter Based on RESULT_CDE Value
'Loop through until EOF
Dim intCaseNumYr1 As Integer
Dim intCaseNum1 As Integer
Dim strCriteria1 As String
Dim strReportName1 As String
Dim strBadRecordKey1 As String
If Not rstRCFL.BOF Then
rstRCFL.MoveFirst
Do Until rstRCFL.EOF
If rstRCFL![RESULT_CDE] = "11" Then
strReportName1 = "FRR-FOFRC11"
intCaseNumYr1 = rstRCFL![CASE_NUM_YR]
intCaseNum1 = rstRCFL![CASE_NUM]
strCriteria1 = "[FRQ-FOFPC20]![CASE_NUM_YR] = " &
intCaseNumYr1 & _
" AND [FRQ-FOFPC20]![CASE_NUM] = " & intCaseNum1
'Print current Record to form FRR-FOFRC11 1 Copy
'DoCmd.OpenReport strReportName1, acViewPreview, ,
strCriteria1
' The following 5 lines of VB code work to open WORD and
Template file,
' but the software fails to allow proper edit controls of
names & data values
' therefore it is not being used at this time, but do not
erase code....
'Dim oApp As Object
'Set oApp = CreateObject("Word.Application")
'oApp.Visible = True
'oApp.Documents.Add "c:\My Access Test.doc"
'DoCmd.Close acForm, "FrmBlank"
ElseIf rstRCFL![RESULT_CDE] > "49" And _
rstRCFL![RESULT_CDE] < "60" Then
'MBox " Like 5xxx " & rstRCFL![RESULT_CDE]
strReportName1 = "FRR-FOFRC5x"
intCaseNumYr1 = rstRCFL![CASE_NUM_YR]
intCaseNum1 = rstRCFL![CASE_NUM]
strCriteria1 = "[FRQ-FOFPC20]![CASE_NUM_YR] = " &
intCaseNumYr1 & _
" AND [FRQ-FOFPC20]![CASE_NUM] = " & intCaseNum1
'MsgBox " Printing 5xxx " & rstRCFL![RESULT_CDE]
'DoCmd.OpenReport strReportName1, acViewPreview, ,
strCriteria1
Else
MsgBox " Invalid Result Code Found In Followng Record"
strBadRecordKey1 = rstRCFL![CASE_NUM_YR] & " " &
rstRCFL![CASE_NUM] & " " & rstRCFL![RESULT_CDE]
MsgBox strBadRecordKey1
End If
rstRCFL.MoveNext
Loop
End If
rstRCFL.Close
Set rstRCFL = Nothing
End Function
Function fncCreateName20Table()
MsgBox " Now Creating DPS_FR_RC20RW_NAMES20 Table "
' This statement Defines the Table named NAMES20
Dim NewTbl As TableDef
Set NewTbl = CurrentDb.CreateTableDef("DPS_FR_RC20RW_NAMES20")
Dim fld1 As Field ' for CASE_NUM_YR
Dim fld2 As Field ' for CASE_NUM
Dim fld3 As Field ' for SEQNO_NUM
Dim fld4 As Field ' for PRTNO_NUM
Dim fld5 As Field ' for NAME_TXT
Dim fld6 As Field ' for FIRM_TXT
Dim fld7 As Field ' for ADDR1_TXT
Dim fld8 As Field ' for ADDR2_TXT
Dim fld9 As Field ' for CITY_TXT
Dim fld10 As Field ' for STATE_CDE
Dim fld11 As Field ' for ZIPCDE_TXT
Set fld1 = NewTbl.CreateField("CASE_NUM_YR", dbLong)
fld1.Required = True
Set fld2 = NewTbl.CreateField("CASE_NUM", dbLong)
fld2.Required = True
Set fld3 = NewTbl.CreateField("SEQNO_NUM", dbLong)
fld3.Required = True
'fld3.Attributes = fld3.Attributes + dbAutoIncrField
Set fld4 = NewTbl.CreateField("PRTNO_NUM", dbLong)
fld4.Required = True
Set fld5 = NewTbl.CreateField("NAME_TXT", dbText, 50)
fld5.Required = True
Set fld6 = NewTbl.CreateField("FIRM_TXT", dbText, 50)
fld6.AllowZeroLength = True
Set fld7 = NewTbl.CreateField("ADDR1_TXT", dbText, 30)
fld7.Required = True
Set fld8 = NewTbl.CreateField("ADDR2_TXT", dbText, 30)
fld8.AllowZeroLength = True
Set fld9 = NewTbl.CreateField("CITY_TXT", dbText, 30)
fld9.Required = True
Set fld10 = NewTbl.CreateField("STATE_CDE", dbText, 2)
fld10.Required = True
Set fld11 = NewTbl.CreateField("ZIPCDE_TXT", dbText, 10)
fld11.AllowZeroLength = True
NewTbl.Fields.Append fld1
NewTbl.Fields.Append fld2
NewTbl.Fields.Append fld3
NewTbl.Fields.Append fld4
NewTbl.Fields.Append fld5
NewTbl.Fields.Append fld6
NewTbl.Fields.Append fld7
NewTbl.Fields.Append fld8
NewTbl.Fields.Append fld9
NewTbl.Fields.Append fld10
NewTbl.Fields.Append fld11
CurrentDb.TableDefs.Append NewTbl
strSQL = "ALTER TABLE DPS_FR_RC20RW_NAMES20 " & _
"ADD CONSTRAINT PK_NAMES20 " & _
"PRIMARY KEY(Case_Num_Yr,Case_Num)"
CurrentDb.Execute strSQL, dbFailOnError
MsgBox " Successfully Created DPS_FR_RC20RW_NAMES20 Table "
End Function
Public Sub subLoad_RC20RW_NAMES20()
On Error GoTo Error_Load_RC20RW_NAMES20
' Insert code to build new names20 records here...
MsgBox " Now entering subLoad_RC20RW_NAMES20 "
Dim rsA As Recordset
Dim rsB As Recordset
Dim rsD As DAO.Recordset
Dim intSelectAtty As Integer
Dim intHoldCaseNumYr As Integer
Dim intHoldCaseNum As Integer
Dim intHoldPrtNoNum As Integer
Dim intSeqNo As Integer
intSeqNo = 0
MsgBox " Now opening rsA "
Set rsA = CurrentDb.OpenRecordset("DPS_FRQ_RC20RW")
MsgBox " Now opening rsB "
Set rsB = CurrentDb.OpenRecordset("DPS_FR_ATTORNEY")
MsgBox " Now opening rsD "
Set rsD = CurrentDb.OpenRecordset("DPS_FR_RC20RW_NAMES20")
If Not (rsA.BOF And rsA.EOF) Then
MsgBox " rsA.BOF and rsA.EOF = " & rsA.BOF & " " & rsA.EOF
rsA.MoveFirst
Do Until rsA.EOF
With rsD
While Not rsA.EOF
'****************************************************************************************
'* If Licensee not null, add Licensee Name, Address, City, State to Table D
*
'****************************************************************************************
If Not IsNull(rsA![LIC_FIRST_NME]) Then
MsgBox " Adding Record = " & rsA![CASE_NUM_YR] & " " & _
rsA![CASE_NUM] & " " & rsA![LIC_LAST_NME]
.AddNew
intHoldCaseNumYr = rsA![CASE_NUM_YR]
intHoldCaseNum = rsA![CASE_NUM]
intHoldPrtNoNum = rsA![PRTNO_NUM]
MsgBox " intHoldCaseNumYr 1 = " & intHoldCaseNumYr
MsgBox " intHoldCaseNum 1 = " & intHoldCaseNum
MsgBox " intHoldPrtNoNum 1 = " & intHoldPrtNoNum
![CASE_NUM_YR] = intHoldCaseNumYr ' build primary
key pt-1
![CASE_NUM] = intHoldCaseNum ' build primary
key pt-2
![SEQNO_NUM] = intSeqNo + 1
![PRTNO_NUM] = intHoldPrtNoNum ' build PRTNO_NUM
![NAME_TXT] = rsA![LIC_FIRST_NME] & " " & _
rsA![LIC_MIDDLE_NME] & " " & _
rsA![LIC_LAST_NME] & " " & _
rsA![LIC_SUBT_TXT]
![FIRM_TXT] = rsA![LIC_LAST_NME]
![ADDR1_TXT] = rsA![LIC_ADDR_TXT]
![ADDR2_TXT] = rsA![LIC_ADDR_TXT]
![CITY_TXT] = rsA![LIC_CITY_NME]
![STATE_CDE] = rsA![LIC_STATE_CDE]
![ZIPCDE_TXT] = rsA![LIC_ZIP_CDE] & " " &
rsA![LIC_ZIP4_CDE]
MsgBox " NAME_TXT 1 = " & rsA!NAME_TXT
.Update
End If
'***********************************************************************
'* If DOA_NME not null, add DOA Name, Address, City, State to Table D
*
'***********************************************************************
If Not IsNull(rsA![DOA_NME]) Then
MsgBox " Adding Record 2 = " & rsA![CASE_NUM_YR] & " " & _
rsA![CASE_NUM] & " " & rsA![DOA_NME]
.AddNew
MsgBox " intHoldCaseNumYr 2 = " & intHoldCaseNumYr
MsgBox " intHoldCaseNum 2 = " & intHoldCaseNum
MsgBox " intHoldPrtNoNum 2 = " & intHoldPrtNoNum
![CASE_NUM_YR] = intHoldCaseNumYr ' build primary
key pt-1
![CASE_NUM] = intHoldCaseNum ' build primary
key pt-2
![SEQNO_NUM] = intSeqNo + 1
![PRTNO_NUM] = intHoldPrtNoNum ' build PRTNO_NUM
![NAME_TXT] = rsA![DOA_NME]
![FIRM_TXT] = Null
![ADDR1_TXT] = rsA![DOA_ADDR_TXT]
![ADDR2_TXT] = Null
![CITY_TXT] = rsA![DOA_CITY_NME]
![STATE_CDE] = rsA![DOA_STATE_CDE]
![ZIP_CDE] = rsA![LIC_ZIP_CDE] & " " & rsA![LIC_ZIP4_CDE]
MsgBox " NAME_TXT 2 = " & rsA![DOA_NME]
.Update
End If
'***********************************************************************
'* If Attorney <> 0, add Attorney Name, Address, City, State to Table D
*
'***********************************************************************
If rsA![ATTY_NUM] <> 0 Then
'select attorney record via sql statement
intSelectAtty = rsA![ATTY_NUM]
MsgBox " Select Attorney # = " & intSelectAtty
DoCmd.runMacro "FRM-Atty-FOF-Select"
If Not (rsB.BOF And rsB.EOF) Then
rsB.MoveFirst
If Not rsB.EOF Then
MsgBox " Adding Record = " & rsA![CASE_NUM_YR] &
" " & _
rsA![CASE_NUM] & " " & rsB![LAST_NME]
MsgBox " intHoldCaseNumYr 3 = " & intHoldCaseNumYr
MsgBox " intHoldCaseNum 3 = " & intHoldCaseNum
MsgBox " intHoldPrtNoNum 3 = " & intHoldPrtNoNum
.AddNew
![CASE_NUM_YR] = intHoldCaseNumYr ' build
pkey pt-1
![CASE_NUM] = intHoldCaseNum ' build
pkey pt-2
![SEQNO_NUM] = intSeqNo + 1
![PRTNO_NUM] = intHoldPrtNoNum ' build
PRTNO_NUM
![NAME_TXT] = rsB![FIRST_NME] & " " & _
rsB![MIDDLE_NME] & " " & _
rsB![LAST_NME] & " " & _
rsB![SUBTITLE_TXT]
![FIRM_NME] = rsB![FIRM_NME]
![ADDR1_TXT] = rsB![ADDR1_TXT]
![ADDR2_TXT] = rsB![ADDR2_TXT]
![CITY_TXT] = rsB![CITY_NME]
![STATE_CDE] = rsB![STATE_CDE]
![ZIP_CDE] = rsB![LIC_ZIP_CDE] & " " &
rsB![LIC_ZIP4_CDE]
MsgBox " NAME_TXT 3 = " & rsB![FIRST_NME]
.Update
End If
End If
End If
rsA.MoveNext
Wend
End With
Loop
End If
rsA.Close
rsB.Close
rsD.Close
Set rsA = Nothing
Set rsB = Nothing
Set rsD = Nothing
Exit_Load_RC20RW_NAMES20:
' Cleanup Code
On Error Resume Next
Exit Sub
Error_Load_RC20RW_NAMES20:
Select Case Err.Number
Case 2501
' Action Cancelled by User, Ignore Error
Case Else
' Unexpected Error Encountered
MsgBox " The following error has occurred: " _
& vbNewLine & " Error Number: " & Err.Number _
& vbNewLine & "Error Description: " & Err.Description _
, vbExclamation, " Unexpected Error "
End Select
Resume Exit_Load_RC20RW_NAMES20
End Sub