Besoin d'aide en vb6.0

Résolu
cs_ramzis_11 Messages postés 13 Date d'inscription mercredi 18 avril 2007 Statut Membre Dernière intervention 25 avril 2007 - 24 avril 2007 à 18:21
jesugeo Messages postés 2 Date d'inscription mercredi 6 juillet 2005 Statut Membre Dernière intervention 12 octobre 2009 - 16 déc. 2008 à 17:20
comment modifier une base de donnée access utiliser en projet vb6.0 , c'est à dire elle es convertie en access 97, et comment je peux lui ajouter des champs et lui supprimer..
MErci d'avance

8 réponses

cs_Exploreur Messages postés 4821 Date d'inscription lundi 11 novembre 2002 Statut Membre Dernière intervention 15 novembre 2016 15
24 avril 2007 à 18:51
Salut,

Déjà Ramzis_11, aie un peu de respect pour toutes les personnes qui veulent bien te répondre...

Tu voulais une réponse toute faite, la voilà :

Module de connection base et fonction :

Option Explicit
 
' Variables info enregistrement,base et options
' Pour affichage dans Frm_Info_Record_Base
 Public Info_Record_modifier As Long
 Public Info_Record_supprimer As Long
 Public Info_Record_valider As Long
 Public Info_Nbr_record_base As Long
 Public TailleSource As Long
 Public NewTailleBase As Long
 Public Etat_Connection As Boolean
 Public ValideCompactage As Boolean
 
' resultat et chemin définitif de la base aprés vérife du ""
 Public CheminBase As String
 
' Variable resultat de la fonction Execute_Sql
 Public Rst_Fonc As Boolean


' Variable pour la requête
 Public Sql As String


' Connection base de données
 Public CnxAdo As New ADODB.Connection
 
' Recordset pour mise à jours bdd
 Public RstAdo As New ADODB.Recordset
 




Public Function Bln_OpenDataBase() As Boolean
   
    ' Gestion erreur
     On Error GoTo Aff_Err


    ' Choix du fournisseur ,ouverture Base de Données
     CnxAdo.Provider = "Microsoft.jet.OLEDB.4.0"
        
    ' Appel founction verif chemin de la base
     Verif_Chemin_Base
    
    ' Resultat de la fonction verif_cehemin_base
     CnxAdo.ConnectionString = CheminBase
       
    ' Ouvre la connection à la source
     CnxAdo.Open
    
    ' Si pas d'erreur connection ok
     Bln_OpenDataBase = True
      
    ' On sort
     Exit Function
    
    
Aff_Err:
' connection échouée suite problème
    Bln_OpenDataBase = False
    Err.Clear


End Function


 


Public Sub ChargeLV(Param_Sql_LV As String)


     ' Paramètres recordset
      RstAdo.CursorLocation = adUseClient 'Emplacement du curseur (espace de stockage temporaire du recordset coté client ou serveur
      RstAdo.CursorType = adOpenDynamic 'Curseur dynamique, les mise à jours sont visibles et tous les mouvements y sont autorisés
      RstAdo.LockType = adLockPessimistic ' Verouillage du record dés son appel
      RstAdo.Sort = "[Nom] ASC"
     
     ' Remplis l'object recordset
      RstAdo.Open Param_Sql_LV, CnxAdo
     
End Sub


 


Public Function Execute_Sql(Param_Sql As String)


    ' Gestion erreur
     On Error GoTo Aff_Err
    
    ' Execution requête avec la l'objet de la connection
     RstAdo.Open Sql, CnxAdo
   
    ' Si pas d'erreur, resultat requête = true
     Rst_Fonc = True
    
    ' On sort
     Exit Function
     
    
Aff_Err:
   
    ' Resultat echec requête
     Rst_Fonc = False
    
    ' Init erreur
     Err.Clear




End Function


 


Public Sub CloseDataBase()
    
    ' Libération ressource
     CnxAdo.Close
     Set CnxAdo = Nothing
     RstAdo.Cancel
     Set RstAdo = Nothing


End Sub




Private Function Verif_Chemin_Base()
   
    ' Variables vérif présence de "" dans le chemin de la base
     Dim Chaine As String
     Dim Dernier_Carract As String


    ' Présence et test ou pas de "" dans le cas
    ' d'un lancement dans ??:\, les ?? représente le lecteur
    ' Car app.path retournera toujours : ??\
       
       ' Donne la chaine retournée de app.path à ma variable
        Chaine = App.Path
       
       ' Prend le dernier carractère de ma variable chaine
        Dernier_Carract = Right(Chaine, 1)
    
       ' Condition suivant présence de ""
        If Dernier_Carract = "" Then
           CheminBase = App.Path & "Turf.mdb"
        Else
           CheminBase = App.Path & "\Turf.mdb"
        End If
          


End Function

Frm_Principal de la source :

Option Explicit ' Pour n'oublier aucune déclarations


Dim Key As Long ' Récupération valeur clé primaire pour suppression
Dim Msg As String ' Texte d'information boite de dialogue
Dim MaxTentative As Integer ' Compteur de tentative de reconnection base
Dim Nb_supprimer As Long ' Nombre total de suppression record


 


Private Sub Form_Load()




    ' Verifie si connection ok via fonction
   
retour: ' Etiquette pour une nouvelle tentative de connection
   
    
     If Bln_OpenDataBase Then
    
        ' connection ok = Bln_OpenDataBase (True)
         Etat_Connection = True
       
     Else
    
        ' Connection échouée = Bln_OpenDataBase(False)
         Etat_Connection = False
        
        ' Message
         Msg = "Une erreur est survenue pendant l'ouverture de la base ! " & vbCrLf & vbCrLf & _
               "Il se peut que la base ne soit plus présente sur le disque, " & vbCrLf & _
               "ou que celle-ci soit endommagée." & vbCrLf & vbCrLf & _
               "Voulez-vous tenter une autre connection ? " & vbCrLf
        
         If MsgBox(Msg, vbCritical Or vbOKCancel, "Connection Base ") = vbOK Then
        
               ' Max 3 tentatives, incrémente le compteur
                MaxTentative = MaxTentative + 1
            
               ' Verification du compteur
                If MaxTentative = 4 Then
               
                   ' informe l'utilisateur
                    Msg = "Vous aves fait 3 tentatives de connection à la base !" & vbCrLf & _
                          "Veuillez vérifier la présence de votre base ou son nom sur le lecteur." & vbCrLf & vbCrLf
                    MsgBox Msg, vbCritical Or vbOKOnly, "Connection Base "
                   
                   ' Fin programe
                    End
                   
                Else
                  
                   ' Si compteur < 3 nouvelles tentatives
                    GoTo retour
                   
                End If
                  
         Else
        
           ' Fin ptogramme
            End
           
         End If
              
     End If


    ' Taille base de donnée avant toutes manipulation (Lbl_taille_base)
     TailleSource = FileLen(CheminBase)
    


    ' Init Générale
     Call Init
    
    ' Affichage de la form avant la Msgbox, pas forcément necéssaire
     Me.Show
   
    ' Information et condition dans Msgbox
     Msg = "Qu'est-ce le compactage des bases de données ?" & vbCrLf & vbCrLf & _
           "Quand vous modifiez la structure de la base (suppression, modification..)" & vbCrLf & _
           "cela laisse le fichier avec des espaces vides et augmente la taille fichier en Ko." & vbCrLf & _
           "L'avantage de faire le compactage, est de diminuer la taille et de supprimer ces espaces.." & vbCrLf & vbCrLf & _
           "Voulez-vous activer le compactage automatiquement ?" & vbCrLf & _
           "(Celui-ci, sera fait au bout de 10 suppressions)" & vbCrLf
    
    ' Choix de l'utilisateur(MsgBox)
     If MsgBox(Msg, vbInformation Or vbOKCancel, "Compactage Base Information") = vbOK Then
        ValideCompactage = True 'Compactage auto
     Else
       ValideCompactage = False 'Pas de compactage auto
     End If
 
    
End Sub




Private Sub cmdannuler_Click()




    ' Init Générale
     Call Init
    
    ' Bouton
     cmdnouveau.Enabled = True
 
 
End Sub




Private Sub Cmdinfo_Click()
   
   
    ' Affichage de la feuille Frm_info_record_base en vbmodal
     Frm_Info_Record_Base.Show (vbModal)
        
        
End Sub


 


Private Sub cmdmodifier_Click()




    ' Gestion erreur
     On Error GoTo Aff_Err


    ' On vérifie que toutes les zones de texte soient remplies
    ' Via fonction
    
         If Bnl_Txt_Test Then
    
                ' Demande de confirmation modification
                 Msg = "Voulez-vous vraiment modifier ce record ?" & vbCrLf & vbCrLf & _
                       "Nom : " & Txt_détails(1).Text & vbCrLf & _
                       "Prénom : " & Txt_détails(2).Text & vbCrLf & vbCrLf
          
                ' Validation ou pas de la modification (choix utilisateur)
                 If MsgBox(Msg, vbExclamation Or vbOKCancel, "Confirmation") = vbOK Then
                  
                   ' Préparation Requête
                     Sql = "UPDATE hippo " & _                           "SET Nom '" & Txt_détails(1).Text & "' , Prénom '" & Txt_détails(2).Text & "'," & _                           "Téléphone " & Txt_détails(3).Text & ", Adresse '" & Txt_détails(4).Text & "' Where N° = " & Key & ";"
                  
                   ' Execution requête
                    Execute_Sql (Sql)
                   
                   ' Traitement Resultat fonction Execute_Sql
                    If Rst_Fonc = False Then
                       Msg = "Une erreur est survenue pendant la modification." & vbCrLf & _
                             "Modification non effectuée !" & vbCrLf & vbCrLf
                            
                             ' Affichage
                              MsgBox Msg, vbExclamation Or vbOKOnly, "Information utilisateur"
                             
                             ' Fermeture RstAdo
                              RstAdo.Close
 
                    End If
 
                   
                   ' Init
                    cmdannuler_Click
                   
                   ' Ajoute à ma variable compteur d'enregistrements modifiés
                    Info_Record_modifier = Info_Record_modifier + 1
                       
                   ' Taille
                    Call Taille
                   
                 End If
                
         Else
                
           ' Resulata Test faux, on sort
            Exit Sub
       
         End If
        
        ' On sort
         Exit Sub
 
Aff_Err:
    ' Type erreur
     MsgBox Err.Description, vbInformation Or vbOKOnly, "Information utilisateur"
     Err.Clear
 
 
End Sub




Private Sub cmdnouveau_Click()




    ' Init zones de texte
     Call TxtVisible(True)


    ' Place le focus
     Txt_détails(1).SetFocus
 
    ' Activation et désactivation bouton
     cmdnouveau.Enabled = False
     cmdvalider.Enabled = True
 
 
End Sub




Private Sub cmdquitter_Click()
 
    ' Sorti programme
     Unload Me
 
End Sub




Private Sub cmdsupprimer_Click()




    ' Gestion erreur
     On Error GoTo Aff_Err


    ' Demande de confirmation suppression
     Msg = "Voulez-vous vraiment supprimer ce record ?" & vbCrLf & vbCrLf & _
           "Nom : " & Txt_détails(1).Text & vbCrLf & _
           "Prénom : " & Txt_détails(2).Text & vbCrLf & vbCrLf
          
     If MsgBox(Msg, vbExclamation Or vbOKCancel, "Confirmation") = vbOK Then
    
        ' Préparation requête         Sql "DELETE FROM hippo WHERE N° " & Key & ""
        
        ' Lancement de la requête
         Execute_Sql (Sql)
        
        ' Traitement Resultat fonction Execute_Sql
         If Rst_Fonc = False Then
            Msg = "Une erreur est survenue pendant la suppression." & vbCrLf & _
                  "Suppression non effectuée !" & vbCrLf & vbCrLf
                 
                  ' Affichage
                   MsgBox Msg, vbExclamation Or vbOKOnly, "Information utilisateur"
                 
                  ' Fermeture RstAdo
                   RstAdo.Close
 
         End If
 
   
        ' Incrémentation compteur suppression et vérife pour compactage(DAO)
         Nb_supprimer = Nb_supprimer + 1
                If (Nb_supprimer) 10 And ValideCompactage True Then
                ' Compactage
                 Call compactage
                ' Init
                 Nb_supprimer = 0
            End If
   
        ' Init
         cmdannuler_Click
                      
        ' Ajoute à ma variable compteur d'enregistrements supprimés
         Info_Record_supprimer = Info_Record_supprimer + 1
       
        ' Taille
         Call Taille
 
     Else
        ' Init
         cmdannuler_Click
    
     End If
    
     ' On sort !
      Exit Sub
     
    
Aff_Err:
     ' Type erreur
      MsgBox Err.Description, vbInformation Or vbOKOnly, "Information utilisateur"
      Err.Clear




End Sub




Private Sub cmdvalider_Click()
    
    
    ' Gestion erreur
     On Error GoTo Aff_Err


    ' On vérifie que toutes les zones de texte soient remplies
    ' Via fonction
   
     If Bnl_Txt_Test Then
       
        '  Préparation de la requête
         Sql = "INSERT INTO hippo(nom,prénom,téléphone,adresse)" & _
               "Values('" & Txt_détails(1).Text & "','" & Txt_détails(2).Text & "'," & Txt_détails(3).Text & ", '" & Txt_détails(4).Text & "')"
       
        ' Lancement de la requête
         Execute_Sql (Sql)
        
        ' Traitement Resultat fonction Execute_Sql
         If Rst_Fonc = False Then
            Msg = "Une erreur est survenue pendant l'enregistrement" & vbCrLf & _
                  "Enregistrement non effectué !" & vbCrLf & vbCrLf
                 
                  ' Affichage
                   MsgBox Msg, vbExclamation Or vbOKOnly, "Information utilisateur"
                  
                  ' Fermeture RstAdo
                   RstAdo.Close
         End If
       
        ' Init
         cmdannuler_Click
                   
        ' Ajoute à ma variable compteur d'enregistrements validés
         Info_Record_valider = Info_Record_valider + 1
       
        ' Taille
         Call Taille
        
     Else
    
        ' Résultat Test faux, on sort
         Exit Sub


     End If
    
    ' On sort
     Exit Sub
    
    
Aff_Err:
  ' Type erreur
   MsgBox Err.Description, vbInformation Or vbOKOnly, "Information utilisateur"
   Err.Clear




End Sub


Private Sub MajLv()




    ' Déclare une variable pour ajouter des objets ListItem.
     Dim itmx As ListItem
 
 
    ' Gestion erreur
     On Error GoTo Aff_Err
 
    ' Ajout des colonnes à la listview
     With Lv
          .ListItems.Clear
          .ColumnHeaders.Clear
          .ColumnHeaders.Add , , "Nom", (.Width * (3 / 8)), lvwColumnLeft
          .ColumnHeaders.Add , , "Prénom", (.Width * (3 / 18)), lvwColumnLeft
          .ColumnHeaders.Add , , "Téléphone", (.Width * (3 / 15)), lvwColumnLeft
          .ColumnHeaders.Add , , "Adresse", (.Width * (3 / 15)), lvwColumnLeft
          .ColumnHeaders.Add , , "Clé Primaire", (.Width * (3 / 15)), lvwColumnLeft
          .View = lvwReport
          .Font.Size = 10
     End With
   
    ' Préparation de la requêtes
     Sql = "SELECT * FROM Hippo"
    
    ' Execution requête
     ChargeLV (Sql)
   
    ' Condition
     If RstAdo.RecordCount = 0 Then
    
        MsgBox "La base de données est vide !", vbExclamation Or vbOKOnly, "Information utilisateur"
       
         ' init compteur nbr_record_base
          Info_Nbr_record_base = 0
       
         ' on ferme le Recordset
          RstAdo.Close
         
        Exit Sub
     End If
           
    ' Incrémentation du compteur et affichage dans le label
     Info_Nbr_record_base = RstAdo.RecordCount




    ' Remplie la listview via la base
     While Not RstAdo.EOF
           Set itmx = Lv.ListItems.Add(, , CStr(RstAdo!Nom))
           itmx.SubItems(1) = RstAdo!Prénom
           itmx.SubItems(2) = RstAdo!Téléphone
           itmx.SubItems(3) = RstAdo!Adresse
           itmx.SubItems(4) = RstAdo!N°
     
          ' Passe à l'enregistrement suivant.
           RstAdo.MoveNext
     Wend
 
    ' Procédure pour largeur automatique de ma Lv
     Call AutoListView1(Me, Lv)
    
    ' On ferme le recordset
     RstAdo.Close
    
    ' On sort
     Exit Sub
    
    
Aff_Err:
    ' Type erreur
     MsgBox Err.Description, vbExclamation Or vbOKOnly, "Information utilisateur"
     Err.Clear
 
 
End Sub




Public Sub AutoListView1(FormeName As Form, Lv As ListView)


' ***** Tout ce code n'est pas de moi, il est de Jack de WWW.VBFRANCE.COM *****
' ***** Merci de ton aide Jack *****


    ' On va régler la largeur des colonnes en fonction du contenu
   
    Dim r As Integer, t As Long, Largeur As Long, Max As Long
   
    ' Donne à la forme la même police que le ListView
    FormeName.Font = Lv.Font
   
    ' 1ere colonne (n'est pas une SubItem)
    ' 1ere valeur : la largeur de l'étiquette
    Max = FormeName.TextWidth(Lv.ColumnHeaders(1).Text)
    For t = 1 To Lv.ListItems.Count
        Largeur = FormeName.TextWidth(Lv.ListItems(t).Text)
        If Largeur > Max Then Max = Largeur
    Next t
    Lv.ColumnHeaders(1).Width = Max * 2
   
    For r = 2 To Lv.ColumnHeaders.Count
        ' 1ere valeur : la largeur de l'étiquette
        Max = FormeName.TextWidth(Lv.ColumnHeaders(r).Text)
        ' Ensuite, le test de ttes les données
        For t = 1 To Lv.ListItems.Count
            Largeur = FormeName.TextWidth(Lv.ListItems(t).SubItems(r - 1))
            If Largeur > Max Then Max = Largeur
        Next t
        Lv.ColumnHeaders(r).Width = Max * 2
    Next r
   
   
End Sub




Private Sub Form_Unload(Cancel As Integer)




' Déconnection base de données
 Call CloseDataBase
 
' Sorti programme
 Unload Me
 
 
End Sub


 


Private Sub Lv_ItemClick(ByVal ItemValide As ListItem)




    ' Variable récupération index Listview
     Dim LongIndex As Long
     
    ' Gestion de l'erreur
     On Error GoTo Aff_Err


    ' Désactivation et activation de certains boutons
     cmdsupprimer.Enabled = True
     cmdmodifier.Enabled = True
     cmdnouveau.Enabled = False


    ' Récupération de l'index
     LongIndex = ItemValide.Index
 
    ' Affichage des zones de texte
     Call TxtVisible(True)
 
    ' Attribution de Clé primaire to Key
    ' Pour suppression ultérieur
      Key = Lv.ListItems(LongIndex).SubItems(4)
          
    ' Affichage dans les zone de text
     Txt_détails(1).Text = Lv.ListItems(LongIndex).Text        ' Nom
     Txt_détails(2).Text = Lv.ListItems(LongIndex).SubItems(1) ' Prénom
     Txt_détails(3).Text = Lv.ListItems(LongIndex).SubItems(2) ' Téléphone
     Txt_détails(4).Text = Lv.ListItems(LongIndex).SubItems(3) ' Adresse
     Txt_détails(0).Text = Lv.ListItems(LongIndex).SubItems(4) ' Clé primaire
    
    ' On sort
     Exit Sub




Aff_Err:
  ' Type erreur
    MsgBox Err.Description, vbExclamation Or vbOKOnly, "Information utilisateur"
  ' Init
    cmdannuler_Click




End Sub




Private Sub Txt_détails_KeyPress(Index As Integer, KeyAscii As Integer)




' On autorise que des chiffres
 If Index = 3 Then
    If Not IsNumeric(Chr(KeyAscii)) Then
           KeyAscii = 0
    End If
 End If
 
 
End Sub




Private Sub compactage()




    ' Variable
     Dim fs As Object ' Object
     Dim Jro As New JetEngine  ' object
     Dim FichierSource As String ' Chemin de la base source
     Dim FichierDest As String ' Chemin de la base Tempo
     Dim TailleDest As Long ' Donnera la taile ko du fichier final compacté
 
    ' Chemin source et tempo
     FichierSource = CheminBase
     FichierDest = CheminBase & "_TMP"
     
    ' Taille fichier source
     TailleSource = FileLen(FichierSource) / 1024
 
 
     ' Déclaration de l'objet
      Set fs = CreateObject("Scripting.FileSystemObject")


          ' Vérification si le fichier existe
           If Not (fs.FileExists(FichierSource)) Then
              MsgBox "Base Introuvable à l'endroit spécifié", vbCritical Or vbOKOnly, "Erreur"
              Exit Sub
              Set fs = Nothing
           End If


    ' Ferme la base car dans tout les cas elle est ouverte
      Call CloseDataBase
        
        ' Compactage de la base de données dans une base temporaire
         Jro.CompactDatabase "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & FichierSource & "", _
        "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & FichierDest & ""
        
        ' Suppression de la Base
         Kill FichierSource
 
        ' Renommage de la Base Tempo
         Name FichierDest As FichierSource
        
        ' Nouvelle taille
         TailleDest = FileLen(FichierSource) / 1024


        ' Informations
         Msg = "Ancienne taile de votre base : " & TailleSource & " Ko" & vbCrLf & _
               "Nouvelle taille de votre base : " & TailleDest & " Ko" & vbCrLf & vbCrLf & _
               "Différence : " & (TailleSource - TailleDest) & " Ko" & vbCrLf & vbCrLf
              
         MsgBox Msg, vbInformation Or vbOKOnly, "Compactage"
       
        ' Re-connection base
         Call Bln_OpenDataBase
        
        ' Taille
         Call Taille
        
        ' On détruit l'object
         Set fs = Nothing
        
 
End Sub




Private Sub TxtVisible(Txt_Aff As Boolean)
   
    Dim Boucle As Integer


    ' Désactive les zones
     For Boucle = 0 To 4
         Txt_détails(Boucle).Text = vbNullString ' efface zone de text
         Txt_détails(Boucle).Visible = Txt_Aff ' zones visible oui / non
     Next Boucle




End Sub




Private Sub ButtonVisible(But_Aff As Boolean)
   
   
    ' Désactive les boutons
     cmdsupprimer.Enabled = But_Aff
     cmdmodifier.Enabled = But_Aff
     cmdvalider.Enabled = But_Aff




End Sub




Private Sub Init()


   
    ' Init Générale
     Call MajLv ' Maj Listview
     Call TxtVisible(False) ' Zones de saisie
     Call ButtonVisible(False) ' Bouton de commande




End Sub




Private Function Bnl_Txt_Test() As Boolean
   
    Dim Boucle_Txt As Integer
    
    ' Test
    
     For Boucle_Txt = 1 To 4
    
        If Txt_détails(Boucle_Txt).Text = vbNullString Then
         
          ' Test faux, on affiche pourquoi
           MsgBox "Veuillez saisir le champ : " & Lbl_détails(Boucle_Txt).Caption, _
           vbExclamation Or vbOKOnly, "Information utilisateur"
          
          ' Focus sur zone vide
           Txt_détails(Boucle_Txt).SetFocus
         
          ' Test faux
           Bnl_Txt_Test = False
          
          ' Sortie
           Exit Function
           
        End If
       
     Next Boucle_Txt
   
    ' Test Ok
     Bnl_Txt_Test = True
    


End Function


Private Sub Taille()
    
    
    ' Calcul nouvelle taille de la base
    ' aprés chaque traitement sur celle-ci
     NewTailleBase = FileLen(CheminBase) / 1024
    
    
End Sub




Maitenant tu n'a plus cas placer les contrôles...

Sur ce bonne prog...


A+
Exploreur


 
3
Rejoignez-nous