frmcensus.frm

Family Tree This a geneology program for entering your family tree. It s a complete working app but

            gccCENINDID & " = " & lngId
    
    Set RS = New ADODB.Recordset
    
    RS.Open SQL, gApp.cn, adOpenForwardOnly, adLockReadOnly
    
    If RS.EOF And RS.BOF Then
        GetCensusInfo = False
        grdMain.Col = 2
        mlcnhID = 0
        Exit Function
    Else
        mlcnhID = RS(gccCENCNHID)
    End If
    RS.Close
    
    SQL = "SELECT * FROM " & gtcCENSUS & " LEFT JOIN " & gtcCENSUSHEADER & " ON " & _
            gtcCENSUS & "." & gccCENCNHID & " = " & gtcCENSUSHEADER & "." & gccCNHID & " WHERE " & _
            gccCNHID & " = " & mlcnhID
            
    Set RS = New ADODB.Recordset
    
    RS.Open SQL, gApp.cn, adOpenForwardOnly, adLockReadOnly
    
    lRow = 0
    
    If Not RS.EOF And Not RS.BOF Then
        Me.Caption = Format(RS(gccCNHYEAR), "0000") & " Census for " & Format(RS(gccCNHADDRESS))
        txtCounty = Format(RS(gccCNHCOUNTY))
        txtCivParish = Format(RS(gccCNHCIVILPARISH))
        txtEccParish = Format(RS(gccCNHECCPARISH))
        txtCountyBorough = Format(RS(gccCNHCOUNTYBOROUGH))
        txtWard = Format(RS(gccCNHWARD))
        txtDistrict = Format(RS(gccCNHRURALDIST))
        txtParlDiv = Format(RS(gccCNHPARLDIV))
        txtTown = Format(RS(gccCNHTOWN))
        txtAddress = Format(RS(gccCNHADDRESS))
        Do While Not RS.EOF
            lRow = lRow + 1
            With grdMain
                If lRow > 1 Then
                    .Rows = .Rows + 1
                End If
                .TextMatrix(lRow, col_Id) = Format(RS(gccCENINDID))
                .TextMatrix(lRow, col_idName) = GetFullName(Val(RS(gccCENINDID)))
                .TextMatrix(lRow, col_Name) = Format(RS(gccCENNAME))
                .TextMatrix(lRow, col_rel) = Format(RS(gccCENRELATION))
                .TextMatrix(lRow, col_Marr) = Format(RS(gccCENMARRIED))
                .TextMatrix(lRow, col_AgeM) = Format(RS(gccCENAGEM))
                .TextMatrix(lRow, col_AgeF) = Format(RS(gccCENAGEF))
                .TextMatrix(lRow, col_Occ) = Format(RS(gccCENOCCUPATION))
                .TextMatrix(lRow, col_Emp) = Format(RS(gccCENEMPLOYER))
                .TextMatrix(lRow, col_WHome) = Format(RS(gccCENWORKINGATHOME))
                .TextMatrix(lRow, col_Born) = Format(RS(gccCENWHEREBORN))
                .TextMatrix(lRow, col_State) = Format(RS(gccCENDEAFDUMBBLIND))
            End With
            RS.MoveNext
        Loop
    End If
            
    grdMain.Col = 2
    grdMain.Row = 1
    lRow = grdMain.Row
    lCol = col_Name
    grdMain.ColSel = grdMain.Cols - 1
    txtEdit.Text = grdMain.TextMatrix(lRow, lCol)
    
    mbChanged = False
    SwitchControls (OFF)
    
Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Function GetCensusInfo"
            
    Call Showerror(sErr, 0)


End Function

Private Sub cmdCancel_Click()
    If mbChanged Then
        If MsgBox("The data on this page has changed. Do you want to save it?", vbYesNo Or vbQuestion, Me.Caption) = vbYes Then
            If Not SaveCensus Then
                Exit Sub
            End If
        End If
    End If
    Unload Me
End Sub

Private Sub cmdFind_Click()
Dim lId As Long

    With grdMain
        lId = frmIndex.invoke(miYear - 110, miYear + 10, "", GetName(Val(.TextMatrix(lRow, col_Id))) & ", " & GetName(Val(.TextMatrix(lRow, col_Id)), True))
        If lId > 0 Then
            .TextMatrix(lRow, col_Id) = lId
            .TextMatrix(lRow, col_idName) = GetFullName(lId)
            txtEdit.Text = .TextMatrix(lRow, col_idName)
            mbChanged = True
            SwitchControls (ONN)
        End If
    End With

End Sub

Private Sub cmdHelp_Click()
    Call ShowHelpContents(Me.hWnd, HelpConstants.cdlHelpContext, Me.HelpContextID)
End Sub

Private Sub cmdSave_Click()
    Call SaveCensus
End Sub

Private Sub grdMain_GotFocus()
    With grdMain
        txtEdit.Top = .CellTop + .Top
        txtEdit.Left = .CellLeft + .Left
        txtEdit.Width = .CellWidth
        txtEdit.Height = .CellHeight
        txtEdit.Text = .TextMatrix(.Row, .Col)
        txtEdit.Visible = True
    End With
End Sub

Private Sub grdMain_RowColChange()
    If lRow <> 0 And lCol <> 0 Then
        grdMain.TextMatrix(lRow, lCol) = txtEdit.Text
    End If
    txtEdit.Top = grdMain.CellTop + grdMain.Top
    txtEdit.Left = grdMain.CellLeft + grdMain.Left
    txtEdit.Width = grdMain.CellWidth
    txtEdit.Height = grdMain.CellHeight
    txtEdit.Text = grdMain.TextMatrix(grdMain.Row, grdMain.Col)
    lRow = grdMain.Row
    lCol = grdMain.Col
    If lCol = col_idName Then
        txtEdit.Locked = True
        cmdFind.Top = grdMain.CellTop + grdMain.Top - ((cmdFind.Height - grdMain.CellHeight) / 2)
        cmdFind.Left = grdMain.CellLeft + grdMain.Left + grdMain.CellWidth
        cmdFind.Visible = True
    Else
        txtEdit.Locked = False
        cmdFind.Visible = False
    End If
    On Error Resume Next
    txtEdit.SetFocus
End Sub

Private Sub txtAddress_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtCivParish_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtCounty_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtCountyBorough_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtDistrict_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtEccParish_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtEdit_KeyDown(KeyCode As Integer, Shift As Integer)
    With grdMain
        Select Case KeyCode
            Case vbKeyRight
                If txtEdit.SelStart >= Len(txtEdit) Then
                    If Shift = 0 Then
                        .TextMatrix(.Row, .Col) = txtEdit.Text
                        If .Col = col_State Then
                            If .Row < .Rows - 1 Then
                                .Row = .Row + 1
                            .Col = col_idName
                            End If
                        Else
                            .Col = .Col + 1
                        End If
                        KeyCode = 0
                    End If
                End If
            Case vbKeyLeft
                If txtEdit.SelStart = 0 Then
                    If Shift = 0 Then
                        If .Col = col_idName Then
                            If .Row > 1 Then
                                .Row = .Row - 1
                                .Col = col_State
                            End If
                        Else
                            .Col = .Col - 1
                        End If
                        KeyCode = 0
                    End If
                End If
            Case vbKeyDown
                .TextMatrix(.Row, .Col) = txtEdit.Text
                If .Row < .Rows - 1 Then
                    .Row = .Row + 1
                End If
                KeyCode = 0
            Case vbKeyUp
                .TextMatrix(.Row, .Col) = txtEdit.Text
                If .Row > 1 Then
                    .Row = .Row - 1
                End If
                KeyCode = 0
        End Select
        .TextMatrix(.Row, .Col) = txtEdit.Text
    End With
End Sub

Private Sub txtEdit_KeyPress(KeyAscii As Integer)
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub SwitchControls(bState As Boolean)
    cmdSave.Enabled = bState
End Sub

Private Function SaveCensus() As Boolean
Dim RS As ADODB.Recordset
Dim SQL As String
Dim sErr As String
Dim idx As Integer

    On Error GoTo ErrSub:

    If ValidDetails Then
        SQL = "Select * from " & gtcCENSUSHEADER & " WHERE "
        If mlcnhID = 0 Then
            SQL = SQL & "1 = 0" 'Blank recordset
        Else
            SQL = SQL & gccCNHID & " = " & mlcnhID
        End If

        Set RS = New ADODB.Recordset
        
        RS.Open SQL, gApp.cn, adOpenKeyset, adLockOptimistic
        
        If mlcnhID <> 0 Then
            If RS.EOF And RS.BOF Then   'If the original has disappeared then create a new one!
                RS.AddNew
            End If
        Else
            RS.AddNew
        End If
        
        RS(gccCNHADDRESS) = Trim(txtAddress)
        RS(gccCNHCIVILPARISH) = Trim(txtCivParish)
        RS(gccCNHCOUNTY) = Trim(txtCounty)
        RS(gccCNHCOUNTYBOROUGH) = Trim(txtCountyBorough)
        RS(gccCNHECCPARISH) = Trim(txtEccParish)
        RS(gccCNHPARLDIV) = Trim(txtParlDiv)
        RS(gccCNHREF) = Trim(txtRef)
        RS(gccCNHRURALDIST) = Trim(txtDistrict)
        RS(gccCNHTOWN) = Trim(txtTown)
        RS(gccCNHWARD) = Trim(txtWard)
        RS(gccCNHYEAR) = miYear
        
        RS.Update
        mlcnhID = RS(gccCNHID)
        
        RS.Close
        
        SQL = "DELETE FROM " & gtcCENSUS & " WHERE " & _
                gccCENCNHID & " = " & mlcnhID
                
        gApp.cn.Execute SQL
        
        SQL = "SELECT * FROM " & gtcCENSUS & " WHERE 1 = 0"
        
        Set RS = New ADODB.Recordset
        
        RS.Open SQL, gApp.cn, adOpenKeyset, adLockOptimistic
        
        For idx = 1 To grdMain.Rows - 1
            With grdMain
                If Trim(.TextMatrix(idx, col_Name)) <> "" Then
                    RS.AddNew
                    RS(gccCENCNHID) = mlcnhID
                    RS(gccCENNAME) = Trim(.TextMatrix(idx, col_Name))
                    RS(gccCENINDID) = Val(.TextMatrix(idx, col_Id))
                    RS(gccCENRELATION) = Trim(.TextMatrix(idx, col_rel))
                    RS(gccCENMARRIED) = Trim(.TextMatrix(idx, col_Marr))
                    RS(gccCENAGEM) = Trim(.TextMatrix(idx, col_AgeM))
                    RS(gccCENAGEF) = Trim(.TextMatrix(idx, col_AgeF))
                    RS(gccCENOCCUPATION) = Trim(.TextMatrix(idx, col_Occ))
                    RS(gccCENEMPLOYER) = Trim(.TextMatrix(idx, col_Emp))
                    RS(gccCENWORKINGATHOME) = Trim(.TextMatrix(idx, col_WHome))
                    RS(gccCENWHEREBORN) = Trim(.TextMatrix(idx, col_Born))
                    RS(gccCENDEAFDUMBBLIND) = Trim(.TextMatrix(idx, col_State))
                    RS.Update

                End If
            End With
        Next idx
        RS.Close
        mbChanged = False
        SwitchControls (OFF)
    End If

Exit Function
ErrSub:
    sErr = Err.Number & vbCrLf & Err.Description & vbCrLf & vbCrLf & _
            "In Module " & Me.Name & vbCrLf & _
            "In Function GetCensusInfo"
            
    Call Showerror(sErr, 0)
    
End Function

Private Function ValidDetails() As Boolean
Dim sMess As String
Dim idx As Integer

    sMess = "You must specify as least one individual link."
    For idx = 1 To grdMain.Rows - 1
        If Val(grdMain.TextMatrix(idx, col_Id)) <> 0 Then
            sMess = ""
            Exit For
        End If
    Next idx

    If sMess = "" Then
        ValidDetails = True
    Else
        MsgBox "You cannot save this data because of the following errors..." & vbCrLf & vbCrLf & sMess, vbOKOnly Or vbCritical, Me.Caption
    End If

End Function

Private Sub txtParlDiv_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtRef_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtTown_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub

Private Sub txtWard_Change()
    mbChanged = True
    SwitchControls (ONN)
End Sub