Hi All, For some reason the code i have in my main form caused access to crash when doing almost anything in the form...i re arranged a few things and it works fine again....but. Could anyone with some experience have a look at my code and point out any shortfalls as im sure there are many.. Just any kind of suggestions would be appreciated
thx
First half (max of 25000 charachters)
thx
First half (max of 25000 charachters)
Code:
Option Compare Database
Private Sub Archived_Click()
Dim strMsg As String
Dim iResponse As Integer
' Specify the message to display.
strMsg = "Are you sure you want to Archive this Inmate?" & Chr(10)
strMsg = strMsg & "Click Yes to Archive or No to Discard changes."
' Display the message box.
iResponse = MsgBox(strMsg, vbQuestion + vbYesNo, "Archive Inmate?")
' Check the user's response.
If iResponse = vbNo Then
If Archived = False Then
Archived = True
Else
Archived = False
End If
End If
End Sub
Private Sub CDOCJBackButton_Click()
If Me.NewRecord Then
MsgBox "You can't print This certificate without a record", vbExclamation, "No Record"
Exit Sub
End If
'
'********************************************************
'Write to word application function
'********************************************************
'
'Declare an instance of Microsoft Word.
Dim Wrd As New Word.Application
Set Wrd = CreateObject("Word.Application")
'Specify the path and name to the Word document.
Dim PathDoc As String
PathDoc = CurrentProject.Path & "\Templates\CDOCJ_form06_back.dotx"
'Open the document template, make it visible.
Wrd.Documents.Add PathDoc
Wrd.Visible = True
'Replace each bookmark with current data.
With Wrd.ActiveDocument.Bookmarks
.Item("LastName").Range.Text = Nz(Me!LastName, emtyValueRepl)
.Item("FirstName").Range.Text = Nz(Me!FirstName, emtyValueRepl)
.Item("MiddleName").Range.Text = Nz(Me!MiddleName, emtyValueRepl)
.Item("NickName").Range.Text = Nz(Me!NickName, emtyValueRepl)
.Item("Gender").Range.Text = Nz(Me!Gender, emtyValueRepl)
.Item("Complexion").Range.Text = Nz(Me!Complexion, emtyValueRepl)
.Item("Race").Range.Text = Nz(Me!Race, emtyValueRepl)
.Item("Height").Range.Text = Nz(Me!Height, emtyValueRepl)
.Item("Weight").Range.Text = Nz(Me!Weight, emtyValueRepl)
.Item("Hair").Range.Text = Nz(Me!Hair, emtyValueRepl)
.Item("Eyes").Range.Text = Nz(Me!Eyes, emtyValueRepl)
.Item("Build").Range.Text = Nz(Me!Build, emtyValueRepl)
.Item("ScarsMarks").Range.Text = Nz(Me!ScarsMarks, emtyValueRepl)
.Item("Address").Range.Text = Nz(Me!AddressStreet, emtyValueRepl) & ", " & Nz(Me!AddressBarangay, emtyValueRepl) & ", " & Nz(Me!AddressDistrict, emtyValueRepl) & ", " & Nz(Me!AddressTown, emtyValueRepl) & ", " & Nz(Me!AddressProvince, emtyValueRepl)
.Item("Occupation").Range.Text = Nz(Me!Occupation, emtyValueRepl)
.Item("PlaceBirth").Range.Text = Nz(Me!PlaceBirth, emtyValueRepl)
.Item("DateBirth").Range.Text = Nz(Me!DateBirth, emtyValueRepl)
.Item("Citizenship").Range.Text = Nz(Me!Nationality, emtyValueRepl)
.Item("TodayDate").Range.Text = Format(Date, "ddddd")
End With
Exit Sub
End Sub
Private Sub CDOCJFrontButton_Click()
If Me.NewRecord Then
MsgBox "You can't print This certificate without a record", vbExclamation, "No Record"
Exit Sub
End If
'
'********************************************************
'Check and if file exists locally and save image to file
'********************************************************
'
'MsgBox Me.Photo.CurrentAttachment
If Me.Photo.AttachmentCount <> 0 Then
Dim strFile As String
'File path to temp jpg file
strFile = CurrentProject.Path & "\Templates\tempProfile.jpg"
'Delete file if it exists
If Dir(strFile) <> "" Then
Kill strFile
End If
' Instantiate the parent recordset.
Set rsInmate = Me.Recordset
' Instantiate the child recordset.
Set rsPhoto = rsInmate.Fields("Photo").Value
' Save current attachment to disk in the "My Documents" folder.
rsPhoto.Fields("FileData").SaveToFile strFile
End If
'
'********************************************************
'Write to word application function
'********************************************************
'
'Declare an instance of Microsoft Word.
Dim Wrd As New Word.Application
Set Wrd = CreateObject("Word.Application")
'Specify the path and name to the Word document.
Dim PathDoc As String
PathDoc = CurrentProject.Path & "\Templates\CDOCJ_form06_front.dotx"
'Open the document template, make it visible.
Wrd.Documents.Add PathDoc
Wrd.Visible = True
'Replace each bookmark with current data.
'
'********************************************************
'Extract all case numbers of current record Start
'********************************************************
'
Dim allCaseNumbers As String
Dim allCrimes As String
Dim allBranches As String
Dim intI As Integer
Dim emtyValueRepl As String
emtyValueRepl = "--"
Dim cnnX As ADODB.Connection
Set cnnX = CurrentProject.Connection
Dim myRecordSet As New ADODB.Recordset
myRecordSet.ActiveConnection = cnnX
myRecordSet.Open "SELECT * FROM tblInmateCases WHERE (((tblInmateCases.InmateID)=" & Me!InmateID & "))"
intI = 1
With myRecordSet
Do Until .EOF
If intI = 1 Then
allCaseNumbers = allCaseNumbers & ![CaseNo]
allCrimes = allCrimes & ![Crime]
allBranches = allBranches & ![Branch]
Else
allCaseNumbers = allCaseNumbers & " / " & ![CaseNo]
allCrimes = allCrimes & " / " & ![Crime]
allBranches = allBranches & " / " & ![Branch]
End If
.MoveNext
intI = intI + 1
Loop
.Close
End With
'
'********************************************************
'Extract all case numbers of current record End
'********************************************************
'
With Wrd.ActiveDocument.Bookmarks
.Item("CaseNo").Range.Text = Nz(allCaseNumbers, emtyValueRepl)
.Item("CaseNo2nd").Range.Text = Nz(allCaseNumbers, emtyValueRepl)
.Item("Crime").Range.Text = Nz(allCrimes, emtyValueRepl)
.Item("Crime2nd").Range.Text = Nz(allCrimes, emtyValueRepl)
.Item("FullName").Range.Text = Nz(Me!LastName, emtyValueRepl) & ", " & Nz(Me!FirstName, emtyValueRepl) & ", " & Nz(Me!MiddleName, emtyValueRepl)
.Item("Branch").Range.Text = Nz(allBranches, emtyValueRepl)
.Item("CivilStatus").Range.Text = Nz(Me!CivilStatus, emtyValueRepl)
.Item("Province").Range.Text = Nz(Me!AddressProvince, emtyValueRepl)
.Item("Languages").Range.Text = Nz(Me!Languages, emtyValueRepl)
.Item("WifeName").Range.Text = Nz(Me!WifeName, emtyValueRepl)
.Item("Education").Range.Text = Nz(Me!Education, emtyValueRepl)
.Item("RelativeNameAddress").Range.Text = Nz(Me!NextKinName, emtyValueRepl) & ", " & Nz(Me!NextKinAddress, emtyValueRepl)
.Item("NotifyNameAddress").Range.Text = Nz(Me!PleaseNotifyName, emtyValueRepl) & ", " & Nz(Me!PleaseNotifyAddress, emtyValueRepl)
.Item("PlaceArrest").Range.Text = Nz(Me!PlaceArrest, emtyValueRepl)
.Item("DateArrest").Range.Text = Nz(Me!DateArrested, emtyValueRepl)
.Item("TimeArrest").Range.Text = Nz(Me!TimeArrested, emtyValueRepl)
.Item("ApprehendedBy").Range.Text = Nz(Me!ApprehendedBy, emtyValueRepl)
.Item("ActualPenaltyImposed").Range.Text = Nz(Me!ActualPenaltyImposed, emtyValueRepl)
.Item("TodayDate").Range.Text = Format(Date, "ddddd")
End With
Exit Sub
End Sub
Private Sub CertDetentButton_Click()
If Me.NewRecord Then
MsgBox "You can't print This certificate without a record", vbExclamation, "No Record"
Exit Sub
End If
'
'********************************************************
'Write to word application function
'********************************************************
'
'Declare an instance of Microsoft Word.
Dim Wrd As New Word.Application
Set Wrd = CreateObject("Word.Application")
'Specify the path and name to the Word document.
Dim PathDoc As String
PathDoc = CurrentProject.Path & "\Templates\certDetention.dotx"
'Open the document template, make it visible.
Wrd.Documents.Add PathDoc
Wrd.Visible = True
'Replace each bookmark with current data.
'
'********************************************************
'Extract all case numbers of current record Start
'********************************************************
'
Dim allCaseNumbers As String
Dim allCrimes As String
Dim allBranches As String
Dim intI As Integer
Dim CurrentAge As String
Dim cnnX As ADODB.Connection
Set cnnX = CurrentProject.Connection
Dim myRecordSet As New ADODB.Recordset
myRecordSet.ActiveConnection = cnnX
myRecordSet.Open "SELECT * FROM tblInmateCases WHERE (((tblInmateCases.InmateID)=" & Me!InmateID & "))"
intI = 1
With myRecordSet
Do Until .EOF
If intI = 1 Then
allCaseNumbers = allCaseNumbers & ![CaseNo]
allCrimes = allCrimes & ![Crime]
allBranches = allBranches & ![Branch]
Else
allCaseNumbers = allCaseNumbers & " / " & ![CaseNo]
allCrimes = allCrimes & " / " & ![Crime]
allBranches = allBranches & " / " & ![Branch]
End If
.MoveNext
intI = intI + 1
Loop
.Close
End With
'
'********************************************************
'Extract all case numbers of current record End
'********************************************************
'
Dim emtyValueRepl As String
emtyValueRepl = "--"
With Wrd.ActiveDocument.Bookmarks
.Item("InmateCaseNumber").Range.Text = Nz(allCaseNumbers, emtyValueRepl)
.Item("InmateAllegedCrime").Range.Text = Nz(allCrimes, emtyValueRepl)
.Item("InmateName").Range.Text = Nz(Me!LastName, emtyValueRepl) & ", " & Nz(Me!FirstName, emtyValueRepl) & ", " & Nz(Me!MiddleName, emtyValueRepl)
.Item("InmateBranch").Range.Text = Nz(allBranches, emtyValueRepl)
.Item("DateMonth").Range.Text = Format(Date, "mmmm")
.Item("DateDay").Range.Text = Format(Date, "dd")
.Item("Year").Range.Text = Format(Date, "yyyy")
.Item("DateCommited").Range.Text = Nz(Me!DateCommited, emtyValueRepl)
.Item("TodayDate").Range.Text = Format(Date, "ddddd")
End With
Exit Sub
End Sub
Private Sub CertDischaButton_Click()
On Error GoTo CertDischaButton_Click_Err
If Me.NewRecord Then
MsgBox "You can't print This certificate without a record", vbExclamation, "No Record"
Exit Sub
End If
If IsNull(Me.DateDischarged) Then
MsgBox "You can't print this certificate without a Discharge Date", vbExclamation, "No Discharge Date"
Exit Sub
End If
OpenChildForm
FilterChildForm
CertDischaButton_Click_Exit:
Exit Sub
CertDischaButton_Click_Err:
MsgBox Error$
Resume CertDischaButton_Click_Exit
End Sub
Private Sub FilterChildForm()
Forms![CertDischargeForm]!ParentInmateIDTextbox = Me![InmateID]
Forms![CertDischargeForm].Filter = "[InmateID] = " & Me![InmateID]
Forms![CertDischargeForm].FilterOn = True
Forms![CertDischargeForm].InmateID = Me![InmateID]
End Sub
Private Sub OpenChildForm()
DoCmd.OpenForm "CertDischargeForm"
End Sub
Private Sub CurrentAgeTextBox_Change()
AgeCurrentTextBox = CurrentAgeTextBox
End Sub
Private Sub FirstName_LostFocus()
FirstName.BackColor = QBColor(15)
End Sub
Private Sub ActualpenaltyimposedTextBox_LostFocus()
ActualpenaltyimposedTextBox.BackColor = QBColor(15)
End Sub
Private Sub Form_AfterUpdate()
' MsgBox "AfterUpdate"
End Sub
Private Sub Form_BeforeUpdate(Cancel As Integer)
'MsgBox "Before"
End Sub
Private Sub Form_Current()
End Sub
Private Sub Form_ExitRecord()
'MsgBox "ExitRecord"
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
'MsgBox "Form_KeyPress KeyAscii = " & KeyAscii
End Sub
Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)
End Sub
Private Sub JailAideB_Click()
If Me.NewRecord Then
MsgBox "You can't print This certificate without a record", vbExclamation, "No Record"
Exit Sub
End If
If Me.JailAide = "No" Then
MsgBox "This Inmate is not a Jail Aide", vbExclamation, "Jail Aide"
Exit Sub
End If
DoCmd.OpenForm "JailAideForm"
'Forms![JailAideForm]!ParentInmateIDTextbox = Me![InmateID]
Forms![JailAideForm].Filter = "[InmateID] = " & Me![InmateID]
Forms![JailAideForm].FilterOn = True
Forms![JailAideForm].InmateID = Me![InmateID]
End Sub
Private Sub ProvincialBackButton_Click()
If Me.NewRecord Then
MsgBox "You can't print This certificate without a record", vbExclamation, "No Record"
Exit Sub
End If
'
'********************************************************
'Write to word application function
'********************************************************
'
'Declare an instance of Microsoft Word.
Dim Wrd As New Word.Application
Set Wrd = CreateObject("Word.Application")
'Specify the path and name to the Word document.
Dim PathDoc As String
PathDoc = CurrentProject.Path & "\Templates\Provincial_form35_back.dotx"
'Open the document template, make it visible.
Wrd.Documents.Add PathDoc
Wrd.Visible = True
'Replace each bookmark with current data.
'
'********************************************************
'Extract all case numbers of current record Start
'********************************************************
'
Dim cnnX As ADODB.Connection
Set cnnX = CurrentProject.Connection
Dim myRecordSet As New ADODB.Recordset
myRecordSet.ActiveConnection = cnnX
myRecordSet.Open "SELECT * FROM tblInmateCases WHERE (((tblInmateCases.InmateID)=" & Me!InmateID & "))"
Dim emtyValueRepl As String
emtyValueRepl = "--"
With Wrd.ActiveDocument.Bookmarks
.Item("FullName").Range.Text = Nz(Me!LastName, emtyValueRepl) & ", " & Nz(Me!FirstName, emtyValueRepl) & ", " & Nz(Me!MiddleName, emtyValueRepl)
End With
Exit Sub
End Sub
Private Sub TypeCombo_AfterUpdate()
If Len(Me.TypeCombo.Value & "") <> 0 And Me.TypeCombo.ListIndex > -1 And Me.TypeCombo.Value <> "All Records" Then
If Me.TypeCombo.Value = "Archived Prisoners" Then
Me.Filter = "Archived = True"
Me.FilterOn = True
ElseIf Me.TypeCombo.Value = "Active Prisoners" Then
Me.Filter = "Archived = False"
Me.FilterOn = True
ElseIf Me.TypeCombo.Value = "Jail Aides" Then
Me.Filter = "Archived = False And JailAide <> 'No'"
Me.FilterOn = True
Else
Me.Filter = "CustodyClassification = '" & Me.TypeCombo.Value & "'And Archived = False"
Me.FilterOn = True
End If
Else
Me.FilterOn = False
End If
End Sub
Private Sub RegionReportB_Click()
'
'********************************************************
'Extract all case numbers of current record Start
'********************************************************
'
Dim allCaseNumbers As String
Dim allCrimes As String
Dim allCaseStatus As String
Dim AllImpPen As String
Dim AllActImpPen As String
Dim AllDateConv As String
Dim FullNameString As String
Dim AllLastHearings As String
Dim reportSql1 As String
Dim reportSql2 As String
Dim reportSqlFull As String
Dim intI As Integer
Dim LTotal As Integer
Dim db As DAO.Database
Set db = CurrentDb
db.Execute "DELETE * FROM tblRegionReport"
reportSql1 = "INSERT INTO tblRegionReport ( InmateID, AgeCommCrime, DateCommited, CustodyClassification, CommAuth, ServOrPrevImp, Counsel) "
reportSql2 = "SELECT tblInmatesProfile.InmateID, tblInmatesProfile.AgeCommited, tblInmatesProfile.DateCommited, tblInmatesProfile.CustodyClassification, tblInmatesProfile.ComAurhority, tblInmatesProfile.PrevImpOrServSentence, tblInmatesProfile.Counsel"
reportSql2 = reportSql2 & " FROM tblInmatesProfile"
reportSql2 = reportSql2 & " WHERE (((tblInmatesProfile.Archived)=False))"
'Turn off warnings and append the records as specified in the SQL.
reportSqlFull = reportSql1 & reportSql2
DoCmd.SetWarnings False
DoCmd.RunSQL reportSqlFull
DoCmd.SetWarnings True
LTotal = DCount("InmateID", "tblRegionReport")
'MsgBox LTotal
Dim emtyValueRepl As String
emtyValueRepl = "--"
Dim cnnX As ADODB.Connection
Set cnnX = CurrentProject.Connection
Dim myRecordSet As New ADODB.Recordset
Dim mySubRecordSet As New ADODB.Recordset
Dim mySubSubRecordSet As New ADODB.Recordset
myRecordSet.ActiveConnection = cnnX
mySubRecordSet.ActiveConnection = cnnX
mySubSubRecordSet.ActiveConnection = cnnX
myRecordSet.Open "SELECT tblInmatesProfile.InmateID,tblInmatesProfile.LastName ,tblInmatesProfile.FirstName ,tblInmatesProfile.MiddleName FROM tblInmatesProfile WHERE (((tblInmatesProfile.Archived)=False))"
'MsgBox myRecordSet.RecordCount
'Exit Sub
myRecordSet.MoveFirst
With myRecordSet
Do Until .EOF
intI = 1
mySubRecordSet.Open "SELECT * FROM tblInmateCases WHERE (((tblInmateCases.InmateID)=" & ![InmateID] & "))"
allCaseNumbers = ""
allCrimes = ""
allCaseStatus = ""
AllImpPen = ""
AllActImpPen = ""
AllDateConv = ""
AllLastHearings = ""
FullNameString = ![LastName] & ", " & ![FirstName] & " " & ![MiddleName]
With mySubRecordSet
Do Until .EOF
'WHERE ListPrice = (SELECT MAX(ListPrice)FROM PRODUCT)
mySubSubRecordSet.Open "SELECT Max(Hearings) As LastHearing FROM tblInmateHearings WHERE (((tblInmateHearings.CaseNumberID)=" & ![CaseNumberID] & ") AND ((tblInmateHearings.Hearings)< Date()))"
'Exit Sub
If intI = 1 Then
allCaseNumbers = allCaseNumbers & Nz(![CaseNo], emtyValueRepl)
allCrimes = allCrimes & Nz(![Crime], emtyValueRepl)
allCaseStatus = allCaseStatus & Nz(![Status], emtyValueRepl)
AllImpPen = AllImpPen & Nz(![ImpPen], emtyValueRepl)
AllActImpPen = AllActImpPen & Nz(![ActPenImp], emtyValueRepl)
AllDateConv = AllDateConv & Nz(![DateConviction], "__")
AllLastHearings = AllLastHearings & Nz(mySubSubRecordSet!LastHearing, "__")
Else
allCaseNumbers = allCaseNumbers & " / " & Nz(![CaseNo], emtyValueRepl)
allCrimes = allCrimes & " / " & Nz(![Crime], emtyValueRepl)
allCaseStatus = allCaseStatus & " / " & Nz(![Status], emtyValueRepl)
AllImpPen = AllImpPen & " / " & Nz(![ImpPen], emtyValueRepl)
AllActImpPen = AllActImpPen & " / " & Nz(![ActPenImp], emtyValueRepl)
AllDateConv = AllDateConv & " - " & Nz(![DateConviction], "__")
AllLastHearings = AllLastHearings & " - " & Nz(mySubSubRecordSet!LastHearing, "__")
End If
mySubSubRecordSet.Close
.MoveNext
intI = intI + 1
Loop
.Close
End With
'MsgBox AllLastHearings
'MsgBox allCaseNumbers
Dim SQLString As String
SQLString = "UPDATE tblRegionReport SET CaseNo = '" & allCaseNumbers
SQLString = SQLString & "', Crime = '" & allCrimes & "', CaseStatus = '" & allCaseStatus
SQLString = SQLString & "', ImpPen = '" & AllImpPen & "', ActPenImp = '" & AllActImpPen
SQLString = SQLString & "', DateConv = '" & AllDateConv & "', FullName = '" & FullNameString
SQLString = SQLString & "', LastHearing = '" & AllLastHearings
SQLString = SQLString & "' WHERE tblRegionReport![InmateID] = " & ![InmateID] & ";"
db.Execute SQLString
.MoveNext
Loop
.Close
End With
DoCmd.OpenReport "RegionReport", 2
End Sub