Annuaire
Description
Bon voila un annuaire.
Il est tres bourrin.
Comme je ne sais pas faire, il enregister tout dans c:\ANNUAIRE\
Il est tres bourrin.
Comme je ne sais pas faire, il enregister tout dans c:\ANNUAIRE\
Source / Exemple :
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
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.