ANNUAIRE

Private Type fiche
    nom As String
    prenom As String
    tel As String
    adresse As String
    email As String
End Type

Const nbMaxPersonnes As Integer = 100

Dim CurFile As String
Dim TabFiche(1 To nbMaxPersonnes) As fiche
Dim nbTabFiche As Integer

Dim TabRecherche(1 To 5 * nbMaxPersonnes) As Integer
Dim nbTabRecherche As Integer
Dim iTabRecherche As Integer

Public Sub SelectionDuBonRepertoire(Lecteur As String)
ChDir Lecteur
SelectRep "ANNUAIRE"
SelectRep "DataAnnuaire"
End Sub


Public Sub SetAbout()
Dim Text1 As String
Dim Text2 As String
Dim Text3 As String
Dim Text4 As String
Dim Text5 As String

Text1 = "-------------------------"
Text2 = "Annuaire"
Text3 = "-------------------------"
Text4 = "JCDjcd"
Text5 = "www.vbfrance.com"

LabelAbout.Caption = Text1 & Chr(13) & Text2 & Chr(13) & Text3 & Chr(13) & Text4 & Chr(13) & Text5

End Sub

Public Sub ClearRecherche()
ButtonPrev.Enabled = False
ButtonNext.Enabled = False
nbTabRecherche = 0
ComboBoxRecherche.Text = ""
LabelNbElement.Caption = "0 / 0"
End Sub

Public Sub ClearTextInput()
TextBoxNom.Text = ""
TextBoxPrenom.Text = ""
TextBoxTel.Text = ""
TextBoxAdresse.Text = ""
TextBoxEmail.Text = ""
End Sub


Public Sub ClearFiche()

LabelNomFiche.Caption = ""
LabelPrenomFiche.Caption = ""
LabelTelFiche.Caption = ""
LabelAdresseFiche.Caption = ""
LabelEmailFiche.Caption = ""

End Sub

Public Sub SelectRep(rep As String)
Dim r As String
r = Dir(rep, vbDirectory)
If r = "" Then
    MkDir rep
End If
ChDir rep
End Sub

Public Function GetAllUsers()

Dim file As String
Dim numberUser As Integer

ListBoxUser.Clear

numberUser = 0
file = Dir("*.anu", vbNormal)

While Not file = ""
    numberUser = numberUser + 1
    ListBoxUser.AddItem (file)
    file = Dir
Wend

GetAllUsers = numberUser

End Function


Private Sub ButonSelectionnerPersonne_Click()

Dim f As fiche

If ListBoxPersonne.ListIndex = -1 Then
    Exit Sub
End If
f = TabFiche(ListBoxPersonne.ListIndex + 1)

LabelNomFiche.Caption = f.nom
LabelPrenomFiche.Caption = f.prenom
LabelTelFiche.Caption = f.tel
LabelAdresseFiche.Caption = f.adresse
LabelEmailFiche.Caption = f.email

End Sub

Private Sub ButtonGo_Click()
Dim f As fiche
Dim a As Integer

If nbTabRecherche = 0 Then
    Exit Sub
End If

a = TabRecherche(iTabRecherche)
f = TabFiche(a)

ListBoxPersonne.ListIndex = a - 1

LabelNomFiche.Caption = f.nom
LabelPrenomFiche.Caption = f.prenom
LabelTelFiche.Caption = f.tel
LabelAdresseFiche.Caption = f.adresse
LabelEmailFiche.Caption = f.email
End Sub

Private Sub ButtonLancerRecherche_Click()
Dim i As Integer, j As Integer
Dim s As String


s = ComboBoxRecherche.Text

If s = "" Then
    ClearRecherche
    Exit Sub
End If

ComboBoxRecherche.AddItem (s)

nbTabRecherche = 0
i = 1
j = 1
While i <= nbTabFiche
    If (Not (InStr(1, TabFiche(i).adresse, s, vbTextCompare) = 0)) Or (Not (InStr(1, TabFiche(i).email, s, vbTextCompare) = 0)) Or (Not (InStr(1, TabFiche(i).nom, s, vbTextCompare) = 0)) Or (Not (InStr(1, TabFiche(i).prenom, s, vbTextCompare) = 0)) Or (Not (InStr(1, TabFiche(i).tel, s, vbTextCompare) = 0)) Then
        
        TabRecherche(j) = i
        j = j + 1
        nbTabRecherche = nbTabRecherche + 1
    End If
    i = i + 1
Wend

ButtonPrev.Enabled = False
If nbTabRecherche = 0 Then
    ButtonNext.Enabled = False
    LabelNbElement.Caption = "0 / 0"
Else
    If nbTabRecherche > 1 Then
        ButtonNext.Enabled = True
    Else
        ButtonNext.Enabled = False
    End If
    iTabRecherche = 1
    ButtonGo_Click
    LabelNbElement.Caption = "1 / " & nbTabRecherche
    
End If

End Sub

Private Sub ButtonNewPersonne_Click()

Dim f As fiche

If CurFile = "" Or nbTabFiche = nbMaxPersonnes Then
    Exit Sub
End If

If TextBoxNom.Text = "" Or TextBoxPrenom = "" Then
    Exit Sub
End If

f.nom = TextBoxNom.Text
f.prenom = TextBoxPrenom.Text

If TextBoxTel.Text = "" Then
    f.tel = " "
Else
    f.tel = TextBoxTel.Text
End If

If TextBoxAdresse.Text = "" Then
    f.adresse = " "
Else
    f.adresse = TextBoxAdresse.Text
End If

If TextBoxEmail.Text = "" Then
    f.email = " "
Else
    f.email = TextBoxEmail.Text
End If

Open CurFile For Random As #1
Seek #1, nbTabFiche + 1
Put #1, , f
Close #1
ClearTextInput
GetAllPersonne
End Sub



Private Sub ButtonNext_Click()

If iTabRecherche = nbTabRecherche - 1 Then
    ButtonNext.Enabled = False
End If

iTabRecherche = iTabRecherche + 1
LabelNbElement.Caption = iTabRecherche & " / " & nbTabRecherche

ButtonGo_Click

If iTabRecherche > 1 Then
    ButtonPrev.Enabled = True
Else
    ButtonPrev.Enabled = False
End If

End Sub

Public Function isNameFileValide(s As String)

If Not InStr(1, s, ".") = 0 Then
    isNameFileValide = False
    Exit Function
End If

If (Not InStr(1, s, ">") = 0) And (Not InStr(1, s, "<") = 0) Then
    isNameFileValide = False
    Exit Function
End If

If (Not InStr(1, s, "/") = 0) And (Not InStr(1, s, "\") = 0) Then
    isNameFileValide = False
    Exit Function
End If


If Not InStr(1, s, ":") = 0 Then
    isNameFileValide = False
    Exit Function
End If

If Not InStr(1, s, "*") = 0 And (Not InStr(1, s, "?") = 0) Then
    isNameFileValide = False
    Exit Function
End If

If Not InStr(1, s, "|") = 0 Then
    isNameFileValide = False
    Exit Function
End If

If Not InStr(1, s, Chr(34)) = 0 Then ' Chr(34) = "
    isNameFileValide = False
    Exit Function
End If

isNameFileValide = True
Exit Function

End Function

Private Sub ButtonNouveau_Click()
Dim NewName As String

NewName = TextBoxNewName.Text

If (Not (NewName = "")) And isNameFileValide(NewName) Then
    Open NewName & ".anu" For Output As #1
    Close #1
    ListBoxUser.AddItem (NewName & ".anu")
    TextBoxNewName.Text = ""
    TextBoxNewName.SetFocus
End If
End Sub

Public Function GetAllPersonne()
Dim f As fiche
Dim nbPersonne As Integer

If CurFile = "" Then
    Exit Function
End If

ClearRecherche

ListBoxPersonne.Clear
Open CurFile For Random As #1
Get #1, , f
nbTabFiche = 0
nbPersonne = 0
While Not f.email = ""
    nbPersonne = nbPersonne + 1
    nbTabFiche = nbTabFiche + 1
    ListBoxPersonne.AddItem (f.nom & " " & f.prenom)
    TabFiche(nbTabFiche) = f
    Get #1, , f
Wend
Close #1
GetAllPersonne = nbPersonne
End Function

Private Sub ButtonPrev_Click()

iTabRecherche = iTabRecherche - 1
LabelNbElement.Caption = iTabRecherche & " / " & nbTabRecherche

ButtonGo_Click

If iTabRecherche = 1 Then
    ButtonPrev.Enabled = False
End If

If iTabRecherche < nbRecherche Then
    ButtonNext.Enabled = False
Else
    ButtonNext.Enabled = True
End If

End Sub

Private Sub ButtonSelectionner_Click()
If ListBoxUser.ListIndex = -1 Or ListBoxUser.Value = "" Then
    Exit Sub
End If
CurFile = ListBoxUser.Text
FrameName.Caption = CurFile & " : "
GetAllPersonne
End Sub

Private Sub ButtonSupprimer_Click()
Dim Selection As String

If ListBoxUser.ListIndex = -1 Then
    Exit Sub
End If

ClearTextInput
ClearFiche
ClearRecherche
CurFile = ""
ListBoxPersonne.Clear

Selection = ListBoxUser.Value
If Not Selection = "" Then
    Kill Selection
    GetAllUsers
End If
End Sub

Private Sub ButtonSupprimerPersonne_Click()
Dim f As fiche
Dim i, a As Integer

a = ListBoxPersonne.ListIndex
If a = -1 Then
    Exit Sub
End If

a = a + 1

Kill CurFile
Open CurFile For Random As #1

i = 1
While i < a
    Put #1, , TabFiche(i)
    i = i + 1
Wend

i = a + 1
While i <= nbTabFiche
    Put #1, , TabFiche(i)
    i = i + 1
Wend

Close #1

If Not GetAllPersonne() = 0 Then
    ListBoxPersonne.SetFocus
    ListBoxPersonne.ListIndex = 0
End If
End Sub

Private Sub ButtonUpDate_Click()
GetAllUsers
End Sub

Private Sub ButtonUpDatePersonne_Click()
GetAllPersonne
End Sub


Private Sub FrameName_Click()

End Sub



Private Sub ListBoxPersonne_Change()
ClearFiche
End Sub

Private Sub ListBoxPersonne_Click()
ButonSelectionnerPersonne_Click
End Sub


Private Sub ListBoxUser_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
ButtonSelectionner_Click
End Sub


Private Sub UserForm_Initialize()


Dim nbUser As Integer

CurFile = ""

SelectionDuBonRepertoire ("c:\")


SetAbout
GetAllUsers

ButtonPrev.Enabled = False
ButtonNext.Enabled = False
nbTabRecherche = 0

End Sub

Télécharger le zip