Soyez le premier à donner votre avis sur cette source.
Vue 3 877 fois - Téléchargée 528 fois
'******************************************************** '****************** 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
Ca me fait plaisir. Effectivement j'y suis peut être allez fort dans l'intro mais je visais comme tu le dis si bien les emmerdeurs. Car apres l'effort, le réconfort ! Et que de déséspoir de se faire allumer par des mecs non respectueux. Je vois bien sur qu'il a des gens sympas :)
Sur ceux, désolé pour l'agressivité mais je suis sur que tu comprends mes reproches.
Merci et @++++ :)
sinon, si tu n'aime pas vb, tu vas sur cppfrance...
pour ton programme, qui en effet n'est pas super bien programmé, vu ke tu es un débutant, il est kan meme pas mal, et aurait peut etre mérité une introduction plus motivante...
7/10... juste pour le programme...
A+
$hîv@n
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.