Programme de gestion d'une liste de vos meilleurs amis :)
Source / Exemple :
'********************************************************
'****************** VARIABLES GLOBALES ******************
'********************************************************
Dim Tableofentry() As String
Dim linenumber2 As Integer
Dim b As Integer
------------------------------------------------------------------------------
'********************************************************
'***************** PREPARATION FLEXGRID *****************
'********************************************************
Private Sub Form_Load()
Frame1.Visible = True
Frame2.Visible = False
Frame8.Visible = False
Frame10.Visible = False
Frame6.Visible = False
Frame4.Visible = False
Picture2.Visible = False
Picture3.Visible = False
Picture4.Visible = False
Picture6.Visible = False
Picture5.Visible = False
Picture1.Visible = True
'Initialisation des noms des colonnes
With Tableau
.Row = 0
.Col = 1
.Text = "Nom"
.Col = 2
.Text = "Prénom"
.Col = 3
.Text = "E-mail"
.Col = 4
.Text = "Naissance"
.Col = 5
.Text = "Adresse"
.Col = 6
.Text = "Code postal"
.Col = 7
.Text = "Ville"
.Col = 8
.Text = "Fixe"
.Col = 9
.Text = "Portable"
End With
'Allignement de celle-ci au centre
For i = 1 To 9
Tableau.Row = 0
Tableau.ColAlignment(i) = 4
Next i
'Appel de la fonction chargeant le contenu du tableau
Chargeinfo
End Sub
--------------------------------------------------------------------
Private Sub Chargeinfo()
'Charge les données dans le tableau
Frame1.Visible = True
Frame2.Visible = False
Frame6.Visible = False
Frame8.Visible = False
Frame10.Visible = False
Frame4.Visible = False
Picture2.Visible = False
Picture3.Visible = False
Picture5.Visible = False
Picture6.Visible = False
Picture4.Visible = False
Picture1.Visible = True
Tableau.Visible = False
texte = FreeFile
Open "Friends.xsv" For Input As #texte
Dim whatrow As Integer
Dim linenumber As Integer
whatrow = 0
'Nombre de ligne dans le fichier
Do Until EOF(texte)
Line Input #texte, buffer
linenumber = linenumber + 1
Loop
Close #texte
If linenumber = 0 Then
MsgBox "Le fichier de donnée est vide !", vbInformation + vbOKOnly, "Erreur"
Else
'Récupération de son contenu
Open "Friends.xsv" For Input As #texte
Do Until EOF(texte)
Input #texte, Nom, Prénom, Mail, Naissance, Adresse, Postal, Ville, fixe, portable
whatrow = whatrow + 1
'Remplissage du tableau (MsFlexgrid)
With Tableau
.AddItem (Row)
.Row = whatrow
.Col = 0
.CellAlignment = 4
.Text = "Friend " + CStr(whatrow)
.Col = 1
.Text = Nom
.Col = 2
.Text = Prénom
.Col = 3
.Text = Mail
.Col = 4
.Text = Naissance
.Col = 5
.Text = Adresse
.Col = 6
.Text = Postal
.Col = 7
.Text = Ville
.Col = 8
.Text = fixe
.Col = 9
.Text = portable
End With
Loop
'Technique de racro pour la largeur des colonnes
Dim maxlenght As Integer
Dim index As Integer
Dim compteur As Integer
For index = 1 To Tableau.Rows - 1
For compteur = 1 To 9
If maxlenght < Printer.TextWidth(Tableau.TextMatrix(index, compteur)) Then
maxlenght = Printer.TextWidth(Tableau.TextMatrix(index, compteur))
Tableau.ColWidth(compteur) = maxlenght
End If
Next compteur
Next index
Tableau.Visible = True
End If
Close #texte
'********************************************************
'*************** FIN PREPARATION FLEXGRID ***************
'********************************************************
End Sub
--------------------------------------------------------------------------------
'********************************************************
'********************* ONGLET NOUVEAU *******************
'********************************************************
Private Sub Command1_click()
'Vérifie que les champs sont tous remplis
If nul = Text1.Text Or nul = Text2.Text Or nul = Text3.Text Or nul = Text7.Text Or nul = Text5.Text Or nul = Text6.Text Or nul = Text4.Text Or nul = Text8.Text Or nul = Text9.Text Then
MsgBox "Attention, les champs ne sont pas tous complets !", vbExclamation + vbOKOnly, "Erreur"
Else
'Si oui, enregistrement
Dim msg
msg = MsgBox("Voulez vous vraiment insérer cet enregistrement dans votre liste d'amis ?", vbQuestion + vbYesNo, "Enregistrement")
If msg = vbYes Then
file = FreeFile
'Enregistrement des textbox dans le fichier
Open "Friends.xsv" For Append As #file
Write #file, Text1.Text, Text2.Text, Text3.Text, Text7.Text, Text4.Text, Text8.Text, Text9.Text, Text5.Text, Text6.Text
Close #file
MsgBox "Entrée réalisée avec succès !", vbInformation + vbOKOnly, "Enregistrement"
'Effacement des textbox
Command2_click
Else
'Si la personne ne veut plus enregistrer
MsgBox "L'insertion n'a pas eu lieu !", vbInformation + vbOKOnly, "Nouvelle entrée"
Command2_click
End If
End If
End Sub
--------------------------------------------------------------------------------------
Private Sub Command2_click()
'Effacement des textbox
Text1.Text = ""
Text2.Text = ""
Text3.Text = ""
Text4.Text = ""
Text5.Text = ""
Text6.Text = ""
Text7.Text = ""
Text8.Text = ""
Text9.Text = ""
'********************************************************
'******************* FIN ONGLET NOUVEAU *****************
'********************************************************
End Sub
--------------------------------------------------------------------------------
'********************************************************
'******************** ONGLET MODIFIER *******************
'********************************************************
Private Sub Modifier_info()
'Variables qui serviront plus tard
linenumber2 = 0
b = 0
file = FreeFile
'Nombre de ligne dans le fichier
Open "Friends.xsv" For Input As #file
Do Until EOF(file)
Line Input #file, buffer
linenumber2 = linenumber2 + 1
Loop
Close #file
'Le tableau est ajusté en fonction du nombre de ligne
ReDim Tableofentry(1 To linenumber2, 9) As String
Open "Friends.xsv" For Input As #file
Do Until EOF(file)
b = b + 1
'On recupere les données et on les met dans le tableau
Input #file, Nom, Prénom, Mail, Naissance, Adresse, Postal, Ville, fixe, portable
Tableofentry(b, 1) = Nom
Tableofentry(b, 2) = Prénom
Tableofentry(b, 3) = Mail
Tableofentry(b, 4) = Naissance
Tableofentry(b, 5) = Adresse
Tableofentry(b, 6) = Postal
Tableofentry(b, 7) = Ville
Tableofentry(b, 8) = fixe
Tableofentry(b, 9) = portable
Loop
Close #file
'On affecte ensuite aux textbox les valeurs par défaut
Text19.Text = Tableofentry(1, 1) + Chr(160) + Tableofentry(1, 2)
Text10.Text = Tableofentry(1, 1)
Text11.Text = Tableofentry(1, 2)
Text12.Text = Tableofentry(1, 3)
Text13.Text = Tableofentry(1, 4)
Text14.Text = Tableofentry(1, 8)
Text15.Text = Tableofentry(1, 9)
Text16.Text = Tableofentry(1, 5)
Text17.Text = Tableofentry(1, 6)
Text18.Text = Tableofentry(1, 7)
b = 1
End Sub
--------------------------------------------------------------------------------
'Bouton pour montrer les entrée en arriere
Private Sub Command5_click()
'Forcément si y a plus d'entrée avant, erreur
If b - 1 <= 0 Then
MsgBox "Vous êtes déja au début de la liste !", vbInformation + vbOKOnly, "Entrée"
Else
'Sinon on affiche l'entrée qui précéde
b = b - 1
Text19.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
Text10.Text = Tableofentry(b, 1)
Text11.Text = Tableofentry(b, 2)
Text12.Text = Tableofentry(b, 3)
Text13.Text = Tableofentry(b, 4)
Text14.Text = Tableofentry(b, 8)
Text15.Text = Tableofentry(b, 9)
Text16.Text = Tableofentry(b, 5)
Text17.Text = Tableofentry(b, 6)
Text18.Text = Tableofentry(b, 7)
End If
End Sub
-------------------------------------------------------------------------------
'Bouton pour montrer les entrée en avançant
Private Sub Command6_click()
'Si plus d'entrée apres, erreur
If b + 1 > linenumber2 Then
MsgBox "Vous êtes déja en fin de liste !", vbInformation + vbOKOnly, "Entrée"
Else
'Sinon affiche de l'entrée qui suit
b = b + 1
Text19.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
Text10.Text = Tableofentry(b, 1)
Text11.Text = Tableofentry(b, 2)
Text12.Text = Tableofentry(b, 3)
Text13.Text = Tableofentry(b, 4)
Text14.Text = Tableofentry(b, 8)
Text15.Text = Tableofentry(b, 9)
Text16.Text = Tableofentry(b, 5)
Text17.Text = Tableofentry(b, 6)
Text18.Text = Tableofentry(b, 7)
End If
End Sub
--------------------------------------------------------------------------
'Bouton pour sauter de 10 entrée en arriere
Private Sub command7_click()
'Si les entrées sont pas assez nombreuses ou que c'est la fin, erreur
If b - 10 <= 0 Then
MsgBox "Nombre d'entrée trop faible ou début de liste atteint !", vbInformation + vbOKOnly, "Entrée"
Else
'Sinon on recule de 10
b = b - 10
Text19.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
Text10.Text = Tableofentry(b, 1)
Text11.Text = Tableofentry(b, 2)
Text12.Text = Tableofentry(b, 3)
Text13.Text = Tableofentry(b, 4)
Text14.Text = Tableofentry(b, 8)
Text15.Text = Tableofentry(b, 9)
Text16.Text = Tableofentry(b, 5)
Text17.Text = Tableofentry(b, 6)
Text18.Text = Tableofentry(b, 7)
End If
End Sub
----------------------------------------------------------------------------
'Bouton pour avancer de 10 entrée
Private Sub Command8_click()
'Si moins de 10 entrée apres ou bien la liste est déja la fin, erreur
If b + 10 > linenumber2 Then
MsgBox "Nombre d'entrée trop faible ou fin de liste atteinte !", vbInformation + vbOKOnly, "Entrée"
Else
'Sinon on avance de 10
b = b + 10
Text19.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
Text10.Text = Tableofentry(b, 1)
Text11.Text = Tableofentry(b, 2)
Text12.Text = Tableofentry(b, 3)
Text13.Text = Tableofentry(b, 4)
Text14.Text = Tableofentry(b, 8)
Text15.Text = Tableofentry(b, 9)
Text16.Text = Tableofentry(b, 5)
Text17.Text = Tableofentry(b, 6)
Text18.Text = Tableofentry(b, 7)
End If
End Sub
------------------------------------------------------------------------------
'Bouton sauvegarder les modifications
Private Sub Command3_click()
'Si certains champs sont nuls, erreur
If nul = Text10.Text Or nul = Text11.Text Or nul = Text12.Text Or nul = Text13.Text Or nul = Text14.Text Or nul = Text15.Text Or nul = Text16.Text Or nul = Text17.Text Or nul = Text18.Text Then
MsgBox "Attention, les champs ne sont pas tous complets !", vbExclamation + vbOKOnly, "Erreur"
Else
'Sinon enregistrement
'La on sauvegarde les champs dans le tableau et on réécrit tout dans le fichier
Dim msg2
file = FreeFile
msg2 = MsgBox("Voulez vous vraiment sauver ces modifications ?", vbQuestion + vbYesNo, "Enregistrement")
If msg2 = vbYes Then
Tableofentry(b, 1) = Text10.Text
Tableofentry(b, 2) = Text11.Text
Tableofentry(b, 3) = Text12.Text
Tableofentry(b, 4) = Text13.Text
Tableofentry(b, 8) = Text14.Text
Tableofentry(b, 9) = Text15.Text
Tableofentry(b, 5) = Text16.Text
Tableofentry(b, 6) = Text17.Text
Tableofentry(b, 7) = Text18.Text
Open "Friends.xsv" For Output As #file
For i = 1 To UBound(Tableofentry)
Write #file, Tableofentry(i, 1), Tableofentry(i, 2), Tableofentry(i, 3), Tableofentry(i, 4), Tableofentry(i, 5), Tableofentry(i, 6), Tableofentry(i, 7), Tableofentry(i, 8), Tableofentry(i, 9)
Next i
Close #file
MsgBox "Modification réalisée avec succès !", vbInformation + vbOKOnly, "Enregistrement"
Text19.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
Command4_click
Else
MsgBox "La modification n'a pas eu lieu !", vbInformation + vbOKOnly, "Nouvelle entrée"
Command4_click
End If
End If
End Sub
----------------------------------------------------------------------------------
'Bouton pour effacer le contenu des textbox
Private Sub Command4_click()
Text10.Text = ""
Text11.Text = ""
Text12.Text = ""
Text13.Text = ""
Text14.Text = ""
Text15.Text = ""
Text16.Text = ""
Text17.Text = ""
Text18.Text = ""
'********************************************************
'****************** FIN ONGLET MODIFIER *****************
'********************************************************
End Sub
------------------------------------------------------------------------------
'********************************************************
'******************* ONGLET SUPPRIMER *******************
'********************************************************
Private Sub Supprimer_info()
'Variables qui serviront plus tard
linenumber2 = 0
b = 0
file = FreeFile
'Nombre de ligne dans le fichier
Open "Friends.xsv" For Input As #file
Do Until EOF(file)
Line Input #file, buffer
linenumber2 = linenumber2 + 1
Loop
Close #file
'Le tableau est ajusté en fonction du nombre de ligne
ReDim Tableofentry(1 To linenumber2, 9) As String
Open "Friends.xsv" For Input As #file
Do Until EOF(file)
b = b + 1
'On recupere les données et on les met dans le tableau
Input #file, Nom, Prénom, Mail, Naissance, Adresse, Postal, Ville, fixe, portable
Tableofentry(b, 1) = Nom
Tableofentry(b, 2) = Prénom
Tableofentry(b, 3) = Mail
Tableofentry(b, 4) = Naissance
Tableofentry(b, 5) = Adresse
Tableofentry(b, 6) = Postal
Tableofentry(b, 7) = Ville
Tableofentry(b, 8) = fixe
Tableofentry(b, 9) = portable
Loop
Close #file
'On affecte ensuite aux textbox les valeurs par défaut
Text20.Text = Tableofentry(1, 1) + Chr(160) + Tableofentry(1, 2)
b = 1
End Sub
----------------------------------------------------------------------------
'Bouton reculer de 1 entrée
Private Sub Command9_click()
If b - 1 <= 0 Then
MsgBox "Vous êtes déja au début de la liste !", vbInformation + vbOKOnly, "Entrée"
Else
b = b - 1
Text20.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
End If
End Sub
---------------------------------------------------------------------------------
'Bouton avancer de 1 entrée
Private Sub Command10_click()
If b + 1 > linenumber2 Then
MsgBox "Vous êtes déja en fin de liste !", vbInformation + vbOKOnly, "Entrée"
Else
b = b + 1
Text20.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
End If
End Sub
'Bouton reculer de 10 entrée
Private Sub Command11_click()
If b - 10 <= 0 Then
MsgBox "Nombre d'entrée trop faible ou début de liste atteint !", vbInformation + vbOKOnly, "Entrée"
Else
b = b - 10
Text20.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
End If
End Sub
-------------------------------------------------------------------------------
'Bouton avancer de 10 entrée
Private Sub Command12_click()
If b + 10 > linenumber2 Then
MsgBox "Nombre d'entrée trop faible ou fin de liste atteinte !", vbInformation + vbOKOnly, "Entrée"
Else
b = b + 10
Text20.Text = Tableofentry(b, 1) + Chr(160) + Tableofentry(b, 2)
End If
End Sub
-----------------------------------------------------------------------
'Bouton supprimer
Private Sub Command13_click()
If linenumber2 <= 1 Then
MsgBox "Impossible de supprimer cet enregistrement. Il doit y avoir obligatoirement 1 entrée !", vbExclamation + vbOKOnly, "Erreur"
Else
Dim msg
msg = MsgBox("Vous confirmez la suppression ?", vbQuestion + vbYesNo, "Suppression")
If msg = vbYes Then
file = FreeFile
Open "Friends.xsv" For Output As #file
For i = 1 To UBound(Tableofentry)
If b <> i Then
Write #file, Tableofentry(i, 1), Tableofentry(i, 2), Tableofentry(i, 3), Tableofentry(i, 4), Tableofentry(i, 5), Tableofentry(i, 6), Tableofentry(i, 7), Tableofentry(i, 8), Tableofentry(i, 9)
End If
Next i
Close #file
MsgBox "Suppression réalisée avec succès !", vbInformation + vbOKOnly, "Suppression"
Text20.Text = Tableofentry(1, 1)
Else
MsgBox "Suppression abandonnée !", vbInformation + vbOKOnly, "Suppression"
End If
End If
'********************************************************
'***************** FIN ONGLET SUPPRIMER *****************
'********************************************************
End Sub
--------------------------------------------------------------------------------
'********************************************************
'******************** ONGLET RECHERCHER *****************
'********************************************************
Private Sub Command14_click()
Dim number As Integer
Dim error As String
If Text21.Text = nul Then
MsgBox "Vous avez omis le texte à rechercher !", vbExclamation + vbOKOnly, "Rechercher"
Else
'Recupere le critere de recherche. Si rien, alors la recherche s'effectue sur tous les criteres
If Option1.Value = True Then
number = 1
ElseIf Option2.Value = True Then
number = 2
ElseIf Option3.Value = True Then
number = 3
ElseIf Option4.Value = True Then
number = 5
ElseIf Option5.Value = True Then
number = 6
ElseIf Option6.Value = True Then
number = 7
ElseIf Option7.Value = True Then
number = 8
ElseIf Option8.Value = True Then
number = 9
ElseIf Option9.Value = True Then
number = 4
End If
If number = 0 Then
MsgBox "Vous devez spécifier un critère dans lequel rechercher la requête", vbInformation + vbOKOnly, "Recherche"
Else
file = FreeFile
Open "Friends.xsv" For Input As #file
Do Until EOF(file)
Line Input #file, buffer
linenumber2 = linenumber2 + 1
Loop
Close #file
ReDim Tableofentry(1 To linenumber2, 9) As String
Open "Friends.xsv" For Input As #file
Do Until EOF(file)
b = b + 1
'On recupere les données et on les met dans le tableau
Input #file, Nom, Prénom, Mail, Naissance, Adresse, Postal, Ville, fixe, portable
Tableofentry(b, 1) = Nom
Tableofentry(b, 2) = Prénom
Tableofentry(b, 3) = Mail
Tableofentry(b, 4) = Naissance
Tableofentry(b, 5) = Adresse
Tableofentry(b, 6) = Postal
Tableofentry(b, 7) = Ville
Tableofentry(b, 8) = fixe
Tableofentry(b, 9) = portable
'Si une entrée correspond au mot rechercher alors on le dit
If (InStr(Text21.Text, Tableofentry(b, number))) Then
error = error + "1 réponse trouvée dans la ligne Friend " + CStr(b) & vbCrLf
End If
Loop
'Si error est nul c'est que aucune réponse n'a été trouvé
If error = nul Then
error = "Désolé, aucune réponse trouvée"
End If
MsgBox error, vbInformation + vbOKOnly, "Recherche"
Close #file
b = 0
End If
End If
End Sub
-------------------------------------------------------------------------------
'Fonction pour rafraichir les button option
Private Sub Option_refresh()
Option1.Value = False
Option2.Value = False
Option3.Value = False
Option4.Value = False
Option5.Value = False
Option6.Value = False
Option7.Value = False
Option8.Value = False
Option9.Value = False
Text21.Text = "Mot à rechercher"
'********************************************************
'****************** FIN ONGLET RECHERCHER ***************
'********************************************************
End Sub
-------------------------------------------------------------------------------
'********************************************************
'******************** ONGLET IMPRIMER *******************
'********************************************************
Private Sub Command15_click()
Printer.Orientation = 2
Printer.PaintPicture Tableau.Picture, 0, 0
Printer.EndDoc
MsgBox "Impression lancée !", vbInformation + vbOKOnly, "Impression"
'********************************************************
'****************** FIN ONGLET IMPRIMER *****************
'********************************************************
End Sub
-------------------------------------------------------------------------------
'Bouton Fichier/Quitter
Private Sub ID1_1_Click()
End
End Sub
'Bouton Fichier/A propos
Private Sub ID2_1_Click()
msg = MsgBox("Projet : Friends reminder Date : 20/05/2002" & vbCrLf & "Auteur : Kephren Environnement : VB 5.0" & vbCrLf & vbCrLf & "Pour tout bug, toute suggestion, tout problême : " & vbCrLf & "Site web : http://www.kephren.fr.fm/" & vbCrLf & "E-mail : hpz_dede@hotmail.com", vbInformation + vbOKOnly, "A propos de Friends reminder")
End Sub
-----------------------------------------------------------------------------------
'Contrôle les onglets du programme
Private Sub Onglet1_Click()
If Onglet1.SelectedItem = "Friends" Then
Tableau.Rows = 1
Tableau.Cols = 10
Chargeinfo
ElseIf Onglet1.SelectedItem = "Nouveau" Then
Frame1.Visible = False
Frame4.Visible = False
Frame6.Visible = False
Frame8.Visible = False
Frame10.Visible = False
Frame2.Visible = True
Picture1.Visible = False
Picture3.Visible = False
Picture5.Visible = False
Picture6.Visible = False
Picture4.Visible = False
Picture2.Visible = True
ElseIf Onglet1.SelectedItem = "Modifier" Then
Frame1.Visible = False
Frame4.Visible = True
Frame8.Visible = False
Frame10.Visible = False
Frame6.Visible = False
Frame2.Visible = False
Picture1.Visible = False
Picture3.Visible = True
Picture5.Visible = False
Picture6.Visible = False
Picture4.Visible = False
Picture2.Visible = False
Modifier_info
ElseIf Onglet1.SelectedItem = "Supprimer" Then
Frame1.Visible = False
Frame4.Visible = False
Frame6.Visible = True
Frame8.Visible = False
Frame10.Visible = False
Frame2.Visible = False
Picture1.Visible = False
Picture3.Visible = False
Picture4.Visible = True
Picture5.Visible = False
Picture6.Visible = False
Picture2.Visible = False
Supprimer_info
ElseIf Onglet1.SelectedItem = "Rechercher" Then
Frame1.Visible = False
Frame4.Visible = False
Frame6.Visible = False
Frame8.Visible = True
Frame10.Visible = False
Frame2.Visible = False
Picture1.Visible = False
Picture3.Visible = False
Picture4.Visible = False
Picture5.Visible = True
Picture6.Visible = False
Picture2.Visible = False
Option_refresh
ElseIf Onglet1.SelectedItem = "Imprimer" Then
Frame1.Visible = False
Frame4.Visible = False
Frame6.Visible = False
Frame8.Visible = False
Frame10.Visible = True
Frame2.Visible = False
Picture1.Visible = False
Picture3.Visible = False
Picture4.Visible = False
Picture5.Visible = False
Picture6.Visible = True
Picture2.Visible = False
End If
End Sub
Conclusion :
Voila amusez vous bien :)
Site web :
http://www.kephren.fr.fm/
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.