cs_ramzis_11
Messages postés13Date d'inscriptionmercredi 18 avril 2007StatutMembreDernière intervention25 avril 2007
-
24 avril 2007 à 18:21
jesugeo
Messages postés2Date d'inscriptionmercredi 6 juillet 2005StatutMembreDernière intervention12 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
cs_Exploreur
Messages postés4821Date d'inscriptionlundi 11 novembre 2002StatutMembreDernière intervention15 novembre 201615 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"
' 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
' 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
' 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
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
' 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"
' 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
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
cs_Exploreur
Messages postés4821Date d'inscriptionlundi 11 novembre 2002StatutMembreDernière intervention15 novembre 201615 24 avril 2007 à 18:26
Salut,
Il y a pleins de source sur le site concernant les bases de données...Fais déjà une petite recherche via le moteur de recherche, ou va directement dans la catégorie : Base de Données..
jmfmarques
Messages postés7666Date d'inscriptionsamedi 5 novembre 2005StatutMembreDernière intervention22 août 201427 24 avril 2007 à 18:39
A ramzis_11 TOUS les sujets que tu as ouverts jusqu'à présent (sans aucune exception) portent un titre analogue à celui que tu as donné à la présente discussion ... titre qui ne signifie rien d'autre que tu es en VB6 (et cette section est justement VB6) et que tu as besoin d'aide (on s'en douterait)...
Je te serais personnellement reconnaissant de bien vouloir dorénavant penser à mettre un titre révêlateur du problème exposé.
merci d'avance de bien vouloir commencer à faire cet effort du bon sens le plus élémentaire !