phonebook.frm

简单、实用、特别。 有很多不足之处

    If Err.Number = 53 Then 'Wrong photopath
        MsgBox "The Picture of this person" & vbCrLf & _
               "Seems to not exist or the path is wrong !"
    End If

End Sub



'***Move within the recordset***'
Private Sub cmdMove_Click(index As Integer)

    On Error GoTo error

    Select Case index
      Case 0 'move to the first record
        objRs.MoveFirst
      Case 1 'move to next record
        objRs.MoveNext
      Case 2 'move to previous record
        objRs.MovePrevious
      Case 3 'move to the last record
        objRs.MoveLast
    End Select
    If objRs.BOF Then objRs.MoveFirst 'if it is the beginning of the file move to the first record
    If objRs.EOF Then objRs.MoveLast 'if it is the end of the file move to the last record
    showCurrentRec
error:

End Sub

'***Get the recordset***'
Private Sub OpenRs()

    On Error GoTo errHandler
    With objRs
        If .State = adStateOpen Then .Close 'if it is open close it

        .ActiveConnection = conString 'to which database to connect to
        .CursorLocation = adUseClient   'Use the cursor on the client
        .CursorType = adOpenKeyset 'Moveable recordset in any direction
        Select Case bolEdit
          Case False 'Readmode
            .LockType = adLockReadOnly 'Read only recordset
          Case True 'Editmode
            .LockType = adLockOptimistic 'Editable recordset
        End Select
        .Source = "select * from tblPhonebook " & WhereString & " order by lastname" 'What to get
        .Open
    End With

    listPers
    objRs.MoveFirst
    showCurrentRec
errHandler:
    If Err.Number = 3021 Then 'if the recordset holds no records (empty database or nothing found in the search)
        If bolSearch = False Then 'Empty database
            NoPostInDb
          Else 'Nothing found in the search
            MsgBox "No records found"
            WhereString = ""
            txtSearch.Text = ""
            cmdEdit(4).Enabled = False
            cmdEdit(4).Caption = ""
            OpenRs
        End If

      ElseIf Err.Number = -2147467259 Then 'if the database is missing
        mnuRestoreBackup_Click
      ElseIf Err.Number <> 0 Then 'in any other error tell what have happen
        MsgBox Err.Number & " " & Err.Description
    End If

End Sub

'***Routine for adding a new post in an empty database
Private Sub NoPostInDb()

  Dim I As Integer

    If MsgBox("You have no posts in your Adress Register!" & vbCrLf & _
       "Do you want to add a new post ?", vbYesNo, "Add a new post") = vbYes Then
        bolEdit = True
        cmdPhotopath.Enabled = True
        For I = 0 To 12
            txtPers(I).Locked = False
        Next I
        For I = 0 To 3 'enable/disable editbuttons
            cmdEdit(I).Enabled = bolEdit
        Next I
        If bolEdit = True Then cmdEdit(3).Enabled = False
        cmdEdit_Click (1)
        MsgBox "Add a new post in your Adress Register" & vbCrLf & _
               "Press AddNew when you are done", , "Add a new post"
      Else
        Exit Sub
    End If

    With objRs
        If .State = adStateOpen Then .Close 'if it is open close it

        .ActiveConnection = conString 'what database to connect to
        .CursorLocation = adUseClient 'Use the clients cursor
        .CursorType = adOpenKeyset 'Moveable recordset in any direction
        .LockType = adLockOptimistic 'Editable recordset
        .Source = "select * from tblPhonebook order by lastname" 'What to get
        .Open
    End With

End Sub

'***List lastname, firstname in the listbox***'
Private Sub listPers()

    lstSelpers.Clear 'empty it first, no duplicates

    With objRs
        .MoveFirst
        While Not .EOF
            lstSelpers.AddItem .Fields(1) & " " & .Fields(2)
            .MoveNext
        Wend
    End With

End Sub

'***Browse to the photopath to store in db***'
Private Sub cmdPhotopath_Click()

    CD1.InitDir = App.Path 'where it should begin to look
    CD1.ShowOpen 'Open the dialog
    txtPers(11).Text = CD1.FileName 'Set the pathname
    Image1.Picture = LoadPicture(CD1.FileName) 'set the picture, to see if it is correct

End Sub

'*** Send mail to person or goto the webpage***'
Private Sub cmdWebEmail_Click(index As Integer)

    frmMail.txtTo = txtPers(9)
    frmMail.Show
    Unload Me

End Sub

Private Sub Form_Load()

    Set objRs = Nothing

    CDCreateOpen2.InitDir = App.Path
    CDCreateOpen2.DialogTitle = "Open Adress Register"
    CDCreateOpen2.FileName = App.Path + "\adressbook.adr"
    AdressRegisterPath = CDCreateOpen2.FileName
    OpenDatabase

    optEditMode_Click (1)

End Sub

Private Sub Form_Unload(Cancel As Integer)

    Set CD1 = Nothing
    Set CD12 = Nothing
    Set CDCreateOpen2 = Nothing

End Sub

'***On click move to the selected record and show it***'
Private Sub lstSelPers_Click()
On Error Resume Next
    objRs.MoveFirst
    objRs.Move (lstSelpers.ListIndex)
    showCurrentRec

End Sub

'***Make a backup of the Adress register***'
Private Sub mnuBackup_Click()

  Dim strTemp As String
  Dim I As Integer

    On Error GoTo errHandler
    Set objRs = Nothing
    CD12.DialogTitle = "Where do you want to put your backup ?"

    For I = 1 To Len(AdressRegisterPath) - 1
        If Mid(AdressRegisterPath, I, 1) = "\" Then
            strTemp = Mid(AdressRegisterPath, 1, I)
        End If
    Next I
    CD12.FileName = Mid(AdressRegisterPath, Len(strTemp) + 1)
    CD12.ShowSave

    If CD12.FileName <> "" Then FileCopy AdressRegisterPath, CD12.FileName
    CD12.FileName = ""
    OpenDatabase
errHandler:
    Set objRs = New ADODB.Recordset

End Sub

'***Create a new adress register***'
Private Sub mnuCreateAdressRegister_Click()
On Error Resume Next
    Set objRs = Nothing

    CDCreateOpen2.InitDir = App.Path
    CDCreateOpen2.DialogTitle = "Create Adress Register as"
    CDCreateOpen2.ShowSave
    If CDCreateOpen2.FileName <> "" Then
        FileCopy App.Path & "\TEMPLATE.bak", CDCreateOpen2.FileName
        AdressRegisterPath = CDCreateOpen2.FileName
        OpenDatabase
    End If

End Sub

'***Select a adress register to open***'
Private Sub mnuOpenAdressRegister_Click()

    Set objRs = Nothing

    CDCreateOpen2.InitDir = App.Path
    CDCreateOpen2.DialogTitle = "Open Adress Register"
    CDCreateOpen2.ShowOpen
    AdressRegisterPath = CDCreateOpen2.FileName
    OpenDatabase

End Sub

'***Restore the AdressRegister***'
Private Sub mnuRestoreBackup_Click()

  Dim strTemp As String
  Dim I As Integer

    On Error GoTo errHandler
    Set objRs = Nothing
    CD12.DialogTitle = "Select Adress Register to restore"
    CD12.ShowOpen
    If CD12.FileName <> "" Then
        AdressRegisterPath = CD12.FileName

        For I = 1 To Len(AdressRegisterPath) - 1
            If Mid(AdressRegisterPath, I, 1) = "\" Then
                strTemp = Mid(AdressRegisterPath, 1, I)
            End If
        Next I
        strTemp = "\" & Mid(AdressRegisterPath, Len(strTemp) + 1)
        FileCopy CD12.FileName, App.Path & strTemp
    End If
    OpenDatabase

errHandler:
    Set objRs = New ADODB.Recordset

End Sub

'***Exit***'
Private Sub mnuExit_Click()

    Unload Me

End Sub

'***Set what kind of recordset to get***'
Private Sub optEditMode_Click(index As Integer)

  Dim I As Integer

    Select Case index
      Case 0 'Readable recordset
        bolEdit = False
        cmdPhotopath.Enabled = False
        For I = 0 To 12
            txtPers(I).Locked = True
        Next I
      Case 1 'Editable recordset
        bolEdit = True
        cmdPhotopath.Enabled = True
        For I = 0 To 12
            txtPers(I).Locked = False
        Next I
    End Select
    For I = 0 To 3 'enable/disable editbuttons
        cmdEdit(I).Enabled = bolEdit
    Next I
    If bolEdit = True Then cmdEdit(3).Enabled = False
    WhereString = ""
    OpenRs

End Sub

'***Set what column to use in the where criteria, also work as search***'
Private Sub optSearch_Click(index As Integer)

    WhereVal = optSearch(index).Caption

End Sub

'***Create part of the string to use in the recordset source***'
Private Sub cmdSearch_Click()

    If WhereVal = "" Then WhereVal = "LastName"
    bolSearch = True
    WhereString = " Where " & WhereVal & " Like '" & txtSearch.Text & "'"
    cmdEdit(4).Enabled = True
    cmdEdit(4).Caption = "Get all posts"
    OpenRs
    bolSearch = False

End Sub

'***Update, Delete, AddNew record and clear textboxes***'
Private Sub cmdEdit_Click(index As Integer)

  Dim I As Integer
  Dim bookMark As Variant

    Select Case index
      Case 0 'Edit and update current record
        If txtPers(0).Text = "" Then
            MsgBox "you must enter a value in Lastname !"
            txtPers(0).SetFocus
          ElseIf txtPers(1).Text = "" Then
            MsgBox "you must enter a value in Firstname !"
            txtPers(1).SetFocus
          Else
            bookMark = objRs.bookMark 'Set bookMark to the current record
            For I = 0 To 12
                If txtPers(I) = "" Then 'Dont store an empty string
                    objRs.Fields(I + 1) = Null
                  Else
                    objRs.Fields(I + 1) = Trim(txtPers(I).Text)
                End If
            Next I
            objRs.Update
            listPers
            objRs.bookMark = bookMark
            showCurrentRec
        End If
      Case 1 'Clear the texboxes and enable AddNew
        cmdEdit(3).Enabled = True
        cmdEdit(0).Enabled = False
        cmdEdit(2).Enabled = False
        cmdEdit(4).Enabled = True
        cmdEdit(4).Caption = "Disable AddNew"
        cmdPhotopath.Enabled = True
        For I = 0 To 12
            txtPers(I).Text = ""
        Next I
      Case 2 'Delete current record
        If MsgBox("Do you want to delete the Post" & vbCrLf & _
           objRs.Fields(1) & " " & objRs.Fields(2) & " ?", vbOKCancel) = vbOK Then
            objRs.Delete adAffectCurrent
            objRs.Requery 'refresh the recordset
            If objRs.RecordCount = 0 Then 'If it was the only record
                For I = 0 To 12
                    txtPers(I).Text = ""
                Next I
                lstSelpers.Clear
                NoPostInDb 'Routine for making a new record in an empty database
              Else
                listPers
                objRs.MoveLast
                showCurrentRec
            End If
        End If
      Case 3 'Addnew, Add a new record to DB
        If txtPers(0).Text = "" Then
            MsgBox "you must enter a value in Lastname !"
            txtPers(0).SetFocus
          ElseIf txtPers(1).Text = "" Then
            MsgBox "you must enter a value in Firstname !"
            txtPers(1).SetFocus
          Else
            objRs.AddNew
            For I = 0 To 12
                If txtPers(I) = "" Then 'Dont store empty strings
                    objRs.Fields(I + 1) = Null
                  Else
                    objRs.Fields(I + 1) = Trim(txtPers(I).Text)
                End If
            Next I
            objRs.Update
            objRs.Requery 'Refresh the recordset
            listPers
            objRs.MoveLast
            showCurrentRec
            cmdEdit(3).Enabled = False 'disable the Addnew cmdbutton
            cmdEdit(0).Enabled = True
            cmdEdit(2).Enabled = True
        End If

      Case 4 'Get Records back after search
        WhereString = ""
        txtSearch.Text = ""
        OpenRs
        If bolEdit = True Then
            cmdEdit(3).Enabled = False
            cmdEdit(0).Enabled = True
            cmdEdit(2).Enabled = True
        End If
        cmdEdit(4).Enabled = False
        cmdEdit(4).Caption = ""
    End Select

End Sub

':) Ulli's VB Code Formatter V2.12.7 (26.06.2002 19:52:39) 12 + 451 = 463 Lines