Annuaire ( ou répertoire...) vraiment simple mais efficace...

Télécharger le projet
Commenter

Description

Ben voilà c'est un petit annuaire...
Il fonctionne plutôt bien... Vous pouvez ajouter des personnes, puis modifier les informations qui les concernent, vous pouvez aussi les supprimer de votre liste...

Les informations sont stockées dans un fichier "annuaire.dat" dans le même répertoire que l'application...

Je l'ai fais en vb6 sous w98... ( d'ailleurs si vous pouviez me dire si ca fonctionne sous d'autres système, ce serait bien sympathique, même si y a pas des raisons que ça ne fonctionne pas, je n'utilise que de petites apis...)

Je suppose que ca devient lent au bout d'un millier de personnes enregistrée...
J'ai fait des test avec plus de 200 personnes référencées et c'était instantanné. ( sur un PII-300 avec 128 de ram...)

Source / Exemple : 


Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Sub ReleaseCapture Lib "user32" ()

'-------------------------------------------'

Const WM_NCLBUTTONDOWN = &HA1
Const HTCAPTION = 2
'-------------------------------------------'
Option Explicit
'-------------------------------------------'

Dim rouge As Integer, vert As Integer, bleu As Integer, ly As Long
Dim r As Variant
Dim i As Integer
Dim buf As String * 128
Dim myFileNumber As Integer, myFileNumber2 As Integer
Dim personnecourante As String
Dim tempDirectory As String, tempfile As String
Dim fond As ColorConstants
Dim Other As String
Dim maLigne As String
Dim lenLine As Long
Dim fichier

Private Sub supprime()
    
    On Error GoTo error

    myFileNumber = FreeFile
    Open fichier For Input As myFileNumber
    myFileNumber2 = FreeFile
    Open tempfile For Append As myFileNumber2
    Do
        Line Input #myFileNumber, maLigne
        If Mid(maLigne, 5, InStr(1, maLigne, ";adresse") - 5) <> lstPrinc.Text Then Print #myFileNumber2, maLigne
    DoEvents
    Loop While Not EOF(myFileNumber)
    
    Close
    Kill fichier
    If FileLen(tempfile) > 0 Then
        FileCopy tempfile, fichier
        Kill tempfile
        Call loadAnnu
    Else
        lstPrinc.Clear
    End If
    
    Exit Sub
    
error:
        
    r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
    Err.Clear
    Resume Next
    
    

End Sub

Private Sub cmdAdd_Click()
    On Error GoTo error

    If txtNom.Text = "" Then
        MsgBox "Vous devez au moins entrez le nom...", vbOKOnly + vbExclamation, "Annuaire..."
        Exit Sub
    End If
    For i = 0 To lstPrinc.ListCount
        If lstPrinc.List(i) = txtNom.Text Then
            r = MsgBox("Cette personne est déjà enregistrée dans l'annuaire... " & vbCrLf & "Voulez modifier les informations la concernant ?", vbYesNo + vbQuestion, "Annuaire...")
            If r = vbNo Then Exit Sub
            Call supprime
        End If
    Next i
    Call ajoute

    Exit Sub
    
error:
        
    r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
    Err.Clear
    Resume Next

End Sub

Private Sub cmdDelete_Click()
    Call supprime
End Sub

Private Sub Form_Activate()
        
    On Error GoTo error
    
    ScaleMode = vbPixels

    DrawStyle = vbInvisible
    FillStyle = vbFSSolid
    Randomize
    
    rouge = Int(Rnd(1) * 128 + 128)
    vert = Int(Rnd(1) * 100 + 128)
    bleu = Int(Rnd(1) * 100 + 128)

    BackColor = RGB(rouge, vert, bleu)

    For ly = -1 To ScaleHeight
        FillColor = RGB(rouge, vert, bleu - (ly * bleu) \ ScaleHeight + 1)
        Line (-1, ly - 1)-(ScaleWidth, ly + 1), , B
    Next
    
    
    fond = &HFFFFFF Xor RGB(rouge, vert, bleu)
    txtNom.ForeColor = FillColor
    txtNom.BackColor = fond
    txtAdresse.ForeColor = FillColor
    txtAdresse.BackColor = fond
    txtTelephone.ForeColor = FillColor
    txtTelephone.BackColor = fond
    txtEmail.ForeColor = FillColor
    txtEmail.BackColor = fond
    txtOther.ForeColor = FillColor
    txtOther.BackColor = fond
    lstPrinc.ForeColor = FillColor
    lstPrinc.BackColor = fond
    
    

    r = GetTempPath(128, buf)
    tempDirectory = Left(buf, r)
    
    If Right(tempDirectory, 1) = "\" Then
        tempfile = tempDirectory & "temp.anu"
    Else
        tempfile = tempDirectory & "\" & "temp.anu"
    End If
    
    If Right(App.Path, 1) = "\" Then
        fichier = App.Path & "annuaire.dat"
    Else
        fichier = App.Path & "\" & "annuaire.dat"
    End If
        
    Call loadAnnu
    
    Exit Sub
    
error:
        
    r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
    Err.Clear
    Resume Next

    
    
    
End Sub

Private Sub ajoute()
    
    On Error GoTo error

    myFileNumber = FreeFile
    Open fichier For Append As myFileNumber
    Other = Replace(txtOther.Text, vbCrLf, "vbcrlf")
    Print #myFileNumber, "nom=" & txtNom.Text & ";adresse=" & txtAdresse.Text & ";telephone=" & txtTelephone.Text & ";email=" & txtEmail.Text & ";other=" & Other
    Close
    
    Call loadAnnu
    
    Exit Sub
    
error:
        
    r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
    Err.Clear
    Resume Next

End Sub

Private Sub loadAnnu()

    On Error GoTo error
    
    lstPrinc.Clear
    
    myFileNumber = FreeFile
    Open fichier For Input As myFileNumber
    Do
        Line Input #myFileNumber, maLigne
        lstPrinc.AddItem (Mid(maLigne, 5, InStr(1, maLigne, ";adresse=") - 5))
    DoEvents
    Loop While Not EOF(myFileNumber)
    Close

    If lstPrinc.ListCount = 0 Then MsgBox "L'annuaire est vide...", vbOKOnly + vbInformation, "Annuaire..."
    
    Exit Sub
    
error:
    
    If Err.Number = 53 Then
        MsgBox "L'annuaire est vide...", vbOKOnly + vbInformation, "Annuaire..."
    Else
        r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
        Err.Clear
        Resume Next
    End If
    
End Sub

Private Sub Form_Paint()

    On Error GoTo error

    For ly = -1 To ScaleHeight
        FillColor = RGB(rouge, vert, bleu - (ly * bleu) \ ScaleHeight + 1)
        Line (-1, ly - 1)-(ScaleWidth, ly + 1), , B
    Next

    Exit Sub
    
error:
        
    r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
    Err.Clear
    Resume Next
    
End Sub

Private Sub imgQuit_Click()
    Unload Me
End Sub

Private Sub imgReduce_Click()
    Me.WindowState = vbMinimized
End Sub

Private Sub lstPrinc_Click()
    On Error GoTo error
    
    myFileNumber = FreeFile
    Open fichier For Input As myFileNumber
    
    Do
        Line Input #myFileNumber, maLigne
        If Mid(maLigne, 5, InStr(1, maLigne, ";adresse") - 5) = lstPrinc.Text Then
            lenLine = Len(maLigne)
            txtNom.Text = lstPrinc.Text
            txtAdresse.Text = Mid(maLigne, InStr(1, maLigne, ";adresse=") + 9, lenLine - ((lenLine - InStr(1, maLigne, ";telephone") + InStr(1, maLigne, ";adresse=") + 9)))
            txtTelephone.Text = Mid(maLigne, InStr(1, maLigne, ";telephone=") + 11, lenLine - ((lenLine - InStr(1, maLigne, ";email") + InStr(1, maLigne, ";telephone=") + 11)))
            txtEmail.Text = Mid(maLigne, InStr(1, maLigne, ";email=") + 7, lenLine - ((lenLine - InStr(1, maLigne, ";other") + InStr(1, maLigne, ";email=") + 7)))
            txtOther.Text = Replace(Mid(maLigne, InStr(1, maLigne, ";other=") + 7, lenLine), "vbcrlf", vbCrLf)
            Exit Do
        End If
    DoEvents
    Loop While Not EOF(myFileNumber)
    
    Close
    
    Exit Sub

error:
    If Err.Number = 53 Then
        MsgBox "Rien n'a encore été entré dans l'annuaire...", vbOKOnly + vbInformation, "Annuaire..."
    Else
        r = MsgBox("Une erreur inattendue est survenue." & vbCrLf & vbCrLf & "Numéro de l'erreur : " & vbCrLf & Err.Number & vbCrLf & vbCrLf & "Description de l'erreur : " & vbCrLf & Err.Description, vbExclamation, "Erreur...")
        Err.Clear
        Resume Next
    End If

End Sub

'-------------------------------------------------------------'

Private Sub lblAdresse_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        r = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub
Private Sub lblEmail_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        r = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub
Private Sub lblNom_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        r = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub
Private Sub lblOther_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        r = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub
Private Sub lblTelephone_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        r = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

Private Sub Form_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = 1 Then
        Call ReleaseCapture
        r = SendMessage(Me.hwnd, WM_NCLBUTTONDOWN, HTCAPTION, 0&)
    End If
End Sub

Conclusion :


Je voulais gérer aussi la lecture seule du fichier "annuaire.dat" mais finalement j'ai eu la flemme de le faire, donc je sais pas trop ce qui se passe lorsqu'on veut écrire dans ce fichier quand il est en lecture seule, normalement comme il y a une gestion généralisée des erreurs donc ça doit afficher un message du genre "Ecrire impossible dans le fichier car il est en lecture seule..."

Je n'ai pas commenté mais si vous insistez je peux le faire...

J'ai mis le code mais comme j'ai fais des trucs graphiques (voir capture... ) pour la forme vaut mieux télécharger le zip...

Soyez sympa laisser des commentaires....
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (cs_Alain Proviste)