DBComp v2.0.6
Table des procédures 1 - frmDBComp (frmDBComp.frm) 1.1 - Private Function bChoisirFichier 1.2 - Private Function bCreerRapportBD 1.3 - Private Function DAODataTypeEnumToString$ 1.4 - Private Sub AfficherMsg 1.5 - Private Sub ChkRequetes_Click 1.6 - Private Sub ChkRqSQL_Click 1.7 - Private Sub CmdComparerBD_Click 1.8 - Private Sub CmdInitBD_Click 1.9 - Private Sub CmdRapport_Click 1.10 - Private Sub CmdTestODBC_Click 1.11 - Private Sub CmdTrouverFichierBD1_Click 1.12 - Private Sub CmdTrouverFichierBD2_Click 1.13 - Private Sub ExporterObjAccess 1.14 - Private Sub ExporterObjAccess0 1.15 - Private Sub Form_Load 1.16 - Private Sub ListerObjBd 1.17 - Private Sub TxtBD1_Change 1.18 - Private Sub TxtBD2_Change 1.19 - Private Sub VerifierOperationsPossibles 1.20 - Public Function bCreerRapportBD_ODBC 1.21 - Public Function bSupprimerEnreg 2 - modADOProp (modADOProp.bas) 2.1 - Private Sub PrintCommandProperties 2.2 - Private Sub PrintConnectionProperties 2.3 - Private Sub PrintFieldProperties 2.4 - Private Sub PrintRecordsetProperties 2.5 - Public Sub ListerPropADO 3 - modSelectionFichier (modSelectionFichier.bas) 3.1 - Public Function bChoisirUnFichier 3.2 - Public Function bChoisirUnFichierAPI 4 - modUtilitaires (modUtil.bas) 4.1 - Public Function asArgLigneCmd 4.2 - Public Function bCreerObjet 4.3 - Public Function bFichierExiste 4.4 - Public Function bIndexRelation 4.5 - Public Function bSupprimerFichier 4.6 - Public Function bTableauVide 4.7 - Public Function sExtraireChemin$ 4.8 - Public Sub AfficherMsgErreur frmDBComp (frmDBComp.frm) Option Explicit ' DBComp : le comparateur de structure de base de données Access (ou ODBC) avec Windiff ' www.vbfrance.com/code.aspx?ID=17847 ' Par Patrice Dargenton ' patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' http://patrice.dargenton.free.fr/CodesSources/DBComp.html ' http://patrice.dargenton.free.fr/CodesSources/DBComp.vbp.html ' www.vbfrance.com/listeauteur2.aspx?ID=1124 ' Documentation : DBComp.html ' Version 2.06 du 18/09/2010 ' Version 2.05 du 12/08/2005 ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % ' l pour Long : & ' r pour nombre Réel : Single! ou Double# ' s pour String : $ ' c pour Char ou Byte ' v pour Variant ' d pour Date ' a pour Array (tableau) : () ' o pour Object : objet instancié localement ' refX pour reference à un objet X préexistant qui n'est pas sensé être fermé ' m_ pour variable Membre de la classe ou de la feuille (Form) ' (mais pas pour les constantes) ' frm pour Form ' cls pour Classe ' mod pour Module ' ... ' ------------------------------------ ' Pour pouvoir localiser la ligne ayant provoqué une erreur, mettre bTrapErr = False 'Private Const bTrapErr As Boolean = False Private Const bTrapErr As Boolean = True ' Récupérer les erreurs Private Const bMDB2Txt As Boolean = True Private Const sPrefixeTableDef$ = "Table Access n°" Private Const sPrefixeStructTableDef$ = "Structure Table Access n°" Private Const sPrefixeModuleDef$ = "Module VBA Access n°" Private Const sPrefixeFormDef$ = "Formulaire VBA Access n°" Private Const sPrefixeEtatDef$ = "Etat VBA Access n°" Private Const sTitreRq$ = "Requêtes :" Private Const sPrefixeRqDef$ = "Requête Access n°" Private Const sTitreDefRq$ = "Définition des requêtes :" Private Const sPrefixeDefRqDef$ = "Définition Requête Access n°" Private Const sTitreRqSys$ = "Définition des requêtes systèmes Access :" 'Private Const sTitreRqSysToutes$ = "Requêtes systèmes Access : Toutes" Private Const sPrefixeRqSysDef$ = "Définition Requête système Access n°" Private Const sTitreProprietesTous$ = "Objets Access et Propriétés : Tous" Private Const sPrefixeMacroDef$ = "Macro Access n°" Private Const sTypeObjetTable$ = "Table" Private Const sTypeObjetModule$ = "Module" Private Const sTypeObjetFormulaire$ = "Formulaire" Private Const sTypeObjetEtat$ = "Etat" Private Const sTypeObjetMacro$ = "Macro" Private Const sTypeObjetRequete$ = "Requête" Private Const sTypeObjetRequeteSys$ = "Requête système" Private Const sGm$ = """" ' Pour la gestion des chemins ou noms de fichier longs ' Utile notamment pour la boîte de dialogue de sélection de fichier Private m_sCheminCourant$ Private Const sMsgTitreBoiteDlg$ = _ "Veuillez choisir une base de données MS-Access ou un fichier ODBC .dsn" Private Const sMsgFiltreBD$ = _ "Base de données MS-Access (*.mdb)" & vbNullChar & "*.mdb" & vbNullChar & _ "Source de données ODBC (*.dsn)" & vbNullChar & "*.dsn" Private Const sFichierDsn_MSAccess_BD1$ = "DVDClass1_MBD.dsn" Private Const sFichierDsn_MSAccess_BD2$ = "DVDClass2_MBD.dsn" Private Const acTable& = 0 Private Const acQuery& = 1 Private Const acForm& = 2 Private Const acReport& = 3 Private Const acMacro& = 4 Private Const acModule& = 5 Private Sub Form_Load() AfficherMsg "" Me.TxtBD1 = "" Me.TxtBD2 = "" Me.TxtBD1 = App.Path & "\DVDClassV1.mdb" Me.TxtBD2 = App.Path & "\DVDClassV2.mdb" 'Me.TxtBD1 = App.Path & "\DVDClass1_MBD.dsn" 'Me.TxtBD2 = App.Path & "\DVDClass2_MBD.dsn" ' Récupérer les arguments de la ligne de commande Dim asArgs$(), i%, iArgMax%, sFichiers$ sFichiers = Command$ asArgs() = asArgLigneCmd(sFichiers) If bTableauVide(asArgs) Then GoTo Suite iArgMax = UBound(asArgs()) For i = 0 To iArgMax If i = 0 Then Me.TxtBD1 = asArgs(0): Me.TxtBD2 = "" If i = 1 Then Me.TxtBD2 = asArgs(1) If i = 2 Then Exit For 'MsgBox (asArgs(i)) Next i Suite: m_sCheminCourant = App.Path If Me.TxtBD1 <> "" Then m_sCheminCourant = sExtraireChemin(Me.TxtBD1) End Sub Private Sub TxtBD1_Change() VerifierOperationsPossibles End Sub Private Sub TxtBD2_Change() VerifierOperationsPossibles End Sub Private Sub ChkRequetes_Click() If Me.ChkRequetes = 0 And Me.ChkRqSQL = 1 Then Me.ChkRqSQL = 0 End Sub Private Sub ChkRqSQL_Click() If Me.ChkRqSQL = 1 And Me.ChkRequetes = 0 Then Me.ChkRequetes = 1 End Sub Private Sub CmdTrouverFichierBD1_Click() Dim sFichier$ If bChoisirFichier(sFichier, sMsgFiltreBD, sMsgTitreBoiteDlg) Then _ Me.TxtBD1 = sFichier VerifierOperationsPossibles End Sub Private Sub CmdTrouverFichierBD2_Click() Dim sFichier$ If bChoisirFichier(sFichier, sMsgFiltreBD, sMsgTitreBoiteDlg) Then _ Me.TxtBD2 = sFichier VerifierOperationsPossibles End Sub Private Function bChoisirFichier(ByRef sFichier$, ByVal sFiltre$, ByVal sTitre$) As Boolean ' Initialiser le chemin seulement la première fois Dim sInitDir$ Static bDejaInit As Boolean If Not bDejaInit Then bDejaInit = True: sInitDir = m_sCheminCourant bChoisirFichier = bChoisirUnFichierAPI(sFichier, sMsgFiltreBD, _ sMsgTitreBoiteDlg, sInitDir, Me.hWnd) End Function Private Sub VerifierOperationsPossibles() Me.CmdRapport.Enabled = False Me.CmdInitBD.Enabled = False Me.CmdComparerBD.Enabled = False If Me.TxtBD1 = "" Then Exit Sub If Not bFichierExiste(Me.TxtBD1) Then Exit Sub Me.CmdRapport.Enabled = True Me.CmdInitBD.Enabled = True If Me.TxtBD2 = "" Then Exit Sub If Not bFichierExiste(Me.TxtBD2) Then Exit Sub If Me.TxtBD2 = Me.TxtBD1 Then Exit Sub Me.CmdComparerBD.Enabled = True End Sub Private Sub CmdInitBD_Click() bSupprimerEnreg Me.TxtBD1 End Sub Private Sub CmdRapport_Click() Dim sCmd$, sCheminRapport1$ If Not bCreerRapportBD(Me.TxtBD1, sCheminRapport1, bConfirm:=False) Then Exit Sub sCmd = "notepad.EXE " & sGm & sCheminRapport1 & sGm Shell sCmd, vbNormalFocus End Sub Private Sub CmdComparerBD_Click() Dim sCmd$, sCheminRapport1$, sRapport2$ If Not bCreerRapportBD(Me.TxtBD1, sCheminRapport1, bConfirm:=False) Then Exit Sub If Me.TxtBD2 = Me.TxtBD1 Then sCmd = "notepad.EXE " & sGm & sCheminRapport1 & sGm GoTo CommandeShell End If If Not bCreerRapportBD(Me.TxtBD2, sRapport2, bConfirm:=False) Then Exit Sub Dim sCheminWinDiff$ sCheminWinDiff = App.Path & "\WINDIFF.EXE" If Not bFichierExiste(sCheminWinDiff) Then MsgBox "Impossible de trouver WinDiff :" & vbLf & _ sCheminWinDiff, vbCritical, "DBComp : Lancement de WinDiff" Exit Sub End If ' Plus nécessaire dans la version du 24/03/2003 : 'Dim sCheminGUtilsDll$ 'sCheminGUtilsDll = App.Path & "\GUTILS.DLL" 'If Not bFichierExiste(sCheminGUtilsDll) Then ' MsgBox "Impossible de trouver GUTILS.DLL :" & vbLf & _ ' sCheminGUtilsDll, vbCritical, "DBComp : Composant de WinDiff" ' Exit Sub 'End If sCmd = sCheminWinDiff & " " & sGm & sCheminRapport1 & sGm & " " & sGm & sRapport2 & sGm CommandeShell: Shell sCmd, vbNormalFocus End Sub Private Function bCreerRapportBD(ByVal sCheminBaseDonnees$, _ ByRef sCheminRapport$, _ Optional ByVal bConfirm As Boolean = True, _ Optional ByVal sCheminBaseSecurite$ = "", _ Optional ByVal sNomCompteUtilisateur$ = "", _ Optional ByVal sPwdCompteUtilisateur$ = "") As Boolean Dim sPrefixeStructTable$ sPrefixeStructTable = "" If bMDB2Txt Then sPrefixeStructTable = sPrefixeStructTableDef If sCheminBaseDonnees = "" Then Exit Function If UCase(Right$(sCheminBaseDonnees, 4)) = ".DSN" Then bCreerRapportBD = bCreerRapportBD_ODBC(sCheminBaseDonnees, _ sCheminRapport, bConfirm, sCheminBaseSecurite, _ sNomCompteUtilisateur, sPwdCompteUtilisateur) Exit Function End If If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 sCheminRapport = Left$(sCheminBaseDonnees, Len(sCheminBaseDonnees) - 3) & "txt" Dim sMsg$ sMsg = "Voulez-vous créer le rapport de base de données suivant :" & vbLf & sCheminRapport & " ?" If bConfirm Then If vbYes <> MsgBox(sMsg, vbQuestion + vbYesNoCancel, sTitreMsg) Then _ Exit Function Me.MousePointer = vbHourglass AfficherMsg "Création du rapport de base de données en cours..." ' Comment s'affranchir du n° de version de DAO ? Liaison tardive ! ' sauf qu'avec DAO, ça ne marche pas ! on est obligé de préciser le n° de version ' on peut cependant tester ainsi plusieurs versions de DAO en cas d'échec ' ce qui est un avantage par rapport à la méthode de la liaison précoce qui ' consiste à préciser les références à DAO 3.6 dans le projet ' Inconvénient de la liaison tardive : l'intellisense n'est pas disponible lors ' de la conception ' Solution : passer en liaison tardive une fois que le projet est débogué ! 'Dim oDBEngine As Object ' il faut aussi oSession as Object, oBd as Object, ... 'Const sCleDAO$ = "DAO.DBEngine.36" ' "Microsoft DAO 3.6 Object Library" 'Set oDBEngine = CreateObject(sCleDAO) 'Set oSession = oDBEngine.Workspaces(0) ' à voir aussi : démarrer le projet sur une fonction Main globale : on peut ' alors faire toutes les vérifications nécessaires, cela ne plante jamais même ' en laison précoce (=anticipée), car les librairies ne sont chargées que si ' elles sont utilisées : cela fonctionne en VB .Net en tout cas Dim bBdOuverte As Boolean, bSessionOuverte As Boolean Dim oBd As DAO.Database, oSession As DAO.Workspace Dim refTable As DAO.TableDef, refProp As DAO.Property Dim refIndex As DAO.Index, refChamp As DAO.Field If sNomCompteUtilisateur = "" Or sCheminBaseSecurite = "" Then ' Ouverture de la base avec le compte admin standard DAO.DBEngine.SystemDB = "" Set oSession = DAO.DBEngine.Workspaces(0) Else ' Ouverture de la base avec un compte sécurisé par mot de passe ' New est une session temporaire DAO.DBEngine.SystemDB = sCheminBaseSecurite Set oSession = DAO.DBEngine.CreateWorkspace("New", _ sNomCompteUtilisateur, sPwdCompteUtilisateur) End If bSessionOuverte = True Set oBd = oSession.OpenDatabase(sCheminBaseDonnees) bBdOuverte = True Dim sNomTable$, lNumFichier&, sDescriptionTable$, bTableLiee As Boolean Dim sTaille$, sType$, sValDef$, sInfo$ Dim bInclureIndex As Boolean, bInclureTablesLiees As Boolean Dim bInclureTypesChamps As Boolean bInclureIndex = False bInclureTablesLiees = False bInclureTypesChamps = False If Me.ChkIndex Then bInclureIndex = True If Me.ChkTablesLiees Then bInclureTablesLiees = True If Me.ChkTypesChamps Then bInclureTypesChamps = True lNumFichier = FreeFile Open sCheminRapport For Output Access Write Lock Read Write As lNumFichier Print #lNumFichier, "Rapport de base de données DBComp : www.vbfrance.com/code.aspx?ID=17847" Print #lNumFichier, "Par Patrice Dargenton : http://patrice.dargenton.free.fr/index.html" Print #lNumFichier, "Base de données : " & oBd.Name ' Version 2.04 : pb résolu : on distingue maintenant les index de table des index de relation 'If bInclureIndex Then Print #lNumFichier, _ "Note : certains index correspondent en fait à des relations entre deux tables" If False = Me.ChkTables Then GoTo Suite ' Parcourir la collection TableDefs : toutes les tables de la base de données Dim iNumTable% iNumTable = 0 For Each refTable In oBd.TableDefs sNomTable = refTable.Name ' Ignorer les tables système If Left(sNomTable, 4) = "MSys" Then GoTo TableSuivante bTableLiee = False If refTable.Connect <> "" Then bTableLiee = True If bTableLiee And Not bInclureTablesLiees Then GoTo TableSuivante sDescriptionTable = "" For Each refProp In refTable.Properties If refProp.Name = "Description" Then ' Une description est disponible pour cette table sDescriptionTable = refProp.Value Exit For End If Next refProp If sDescriptionTable = "" Then sDescriptionTable = "(null)" ' Masquer les tables dont la description contient le mot "masquer" If InStr(sDescriptionTable, "masquer") > 0 Then GoTo TableSuivante Dim sAffTable$ sAffTable = sNomTable & " : " & sDescriptionTable iNumTable = iNumTable + 1 If bMDB2Txt Then sAffTable = sPrefixeStructTable & iNumTable & " : " & _ sNomTable & " : " & sDescriptionTable Print #lNumFichier, "" ' Saut de ligne Print #lNumFichier, sAffTable ' Parcourir les champs de la table For Each refChamp In refTable.Fields If bInclureTypesChamps Then sTaille = refChamp.Size sType = DAODataTypeEnumToString(refChamp.Type, sTaille) sValDef = refChamp.DefaultValue sInfo = " (" & sType If sValDef <> "" Then sInfo = sInfo & " : " & sValDef & ")" Else sInfo = sInfo & ")" End If End If ' Ne marche pas : on est obligé de parcourir la collection ! 'Set refProp = refChamp.Properties!Description 'refProp = refChamp.Properties("Description") Dim bDescription As Boolean, sChampRequis$ bDescription = False sChampRequis = "" If refChamp.Required Then sChampRequis = " (Null interdit)" For Each refProp In refChamp.Properties If refProp.Name = "Description" Then bDescription = True Print #lNumFichier, " " & refChamp.Name & sInfo & " : " & _ refProp.Value & sChampRequis End If Next refProp If Not bDescription Then ' Si la description est nulle, la propriété n'existe pas Print #lNumFichier, " " & refChamp.Name & sInfo & " : (null)" End If Next refChamp ' Dans tous les cas, afficher au moins les index uniques ' (mais pas les primaires numériques automatiques) 'If Not bInclureIndex Then GoTo TableSuivante ' Parcourir la liste des index de la table ' Ne marche pas avec les tables liées ' (et la gestion d'erreur ne marche pas dans ce cas ?) If bTableLiee Then GoTo TableSuivante On Error GoTo TableSuivante0 For Each refIndex In refTable.Indexes If Not bInclureIndex And refIndex.Primary And refIndex.Unique And _ refIndex.Fields.Count = 1 Then Dim sChamp$, sType0$ sChamp = refIndex.Fields(0).Name sType0 = DAODataTypeEnumToString(refTable.Fields(sChamp).Type) ' C'est un simple index identifiant numérique, on ne l'affiche pas If sType0 = "Long" Then GoTo IndexSuivant End If ' Si on n'affiche pas le détail des index, passer à l'index suivant If Not bInclureIndex And Not refIndex.Primary And _ Not refIndex.Unique Then GoTo IndexSuivant ' Ne pas inclure les index créé par Access en interne ' pour la gestion des relations : entre {} ' sauf si on affiche toutes les propriétés Dim bIndexRelation0 As Boolean, sIndex$ bIndexRelation0 = False If Left$(refIndex.Name, 1) = "{" Then bIndexRelation0 = True If bIndexRelation(oBd, refIndex.Name) Then bIndexRelation0 = True If bIndexRelation0 And False = Me.ChkProp Then GoTo IndexSuivant sIndex = "Index : " If bIndexRelation0 Then sIndex = "IndexRel: " Print #lNumFichier, " " & sIndex & refIndex.Name & _ IIf(refIndex.Fields.Count > 1, ", " & refIndex.Fields.Count & _ " champs", "") & _ IIf(refIndex.Unique, ", Unique", "") & _ IIf(refIndex.Primary, ", Primary", "") ' Si un seul champ index = nom index, alors inutile de répéter le champ If refIndex.Fields.Count = 1 Then If refIndex.Fields(0).Name = refIndex.Name Then GoTo IndexSuivant End If ' Parcourir les champs de l'index For Each refChamp In refIndex.Fields Print #lNumFichier, " champ : " & refChamp.Name Next refChamp IndexSuivant: Next refIndex TableSuivante0: Err.Clear If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 TableSuivante: Next refTable Suite: If Me.ChkRequetes = False Then GoTo Suite2 ' Parcourir la collection QueryDefs : toutes les requêtes de la base de données Dim refQd As DAO.QueryDef, sRq$, sDescription$ Dim bAuMoinsUneRq As Boolean Dim iNumRq% iNumRq = 0 For Each refQd In oBd.QueryDefs sRq = refQd.Name If Left$(sRq, 1) = "~" Then GoTo RequeteSuivante If Not bAuMoinsUneRq Then Print #lNumFichier, "" Print #lNumFichier, "" Print #lNumFichier, sTitreRq Print #lNumFichier, "" End If bAuMoinsUneRq = True sDescription = "" Err.Clear On Error Resume Next sDescription = refQd.Properties("Description") If sDescription = "" Then sDescription = "(null)" sRq = sRq & " : " & sDescription Dim sAffRq$ sAffRq = sRq iNumRq = iNumRq + 1 If bMDB2Txt Then sAffRq = sPrefixeRqDef & iNumRq & " : " & sRq Print #lNumFichier, sAffRq If Me.ChkRqSQL Then Print #lNumFichier, refQd.SQL End If RequeteSuivante: Next refQd Suite2: If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 If Me.ChkProp Then ListerObjBd oBd, lNumFichier, bListerProp:=True Close lNumFichier If Me.ChkRq Or Me.ChkFrm Or Me.ChkEtats Or Me.ChkMacros Or Me.ChkMod Or _ Me.ChkTablesDonnees Then _ ExporterObjAccess sCheminRapport, oBd.Name If bConfirm Then sMsg = "Création du rapport de base de données terminée :" & vbLf & _ sCheminRapport MsgBox sMsg, vbExclamation, sTitreMsg End If bCreerRapportBD = True Fin: On Error Resume Next 'Close lNumFichier Close ' Fermer tous les fichiers ouverts If bBdOuverte And Not (oBd Is Nothing) Then oBd.Close If bSessionOuverte And Not (oSession Is Nothing) Then oSession.Close AfficherMsg "" Me.MousePointer = vbDefault Exit Function Erreur: Me.MousePointer = vbDefault AfficherMsgErreur Err, "bCreerRapportBD" Resume Fin End Function Private Sub AfficherMsg(ByVal sMsg$) Me.LblInfo = sMsg DoEvents ' Pour voir le message LblInfo ! End Sub Private Sub ExporterObjAccess(ByVal sCheminRapport$, ByVal sCheminBd$) ' Exporter les objets d'une base de données Access, ' ainsi que le contenu des tables ' Pour les formulaires et les états, inclure leur code de description complet ' (Code Design), ainsi que le code source de leur module : ' ils sont rechargeables via LoadAsText ! ' Prochainement, cette fonctionnalité va permettre de faire un super-compacteur ! ' SaveAsText et LoadAsText sont des fonctions non documentées d'Access ' conçues pour gérer le développement sous Access, depuis un contrôleur ' de code source du type VisualSourceSafe, elles sont donc fiables à 100% ' Astuce trouvée dans : Access 97 Developers's Handbook ' Supprimer le fichier temporaire s'il existe Dim sCheminTxtTmp$ sCheminTxtTmp = App.Path & "\tmp.txt" If False = bSupprimerFichier(sCheminTxtTmp) Then Exit Sub ' Créer une instance d'Access Dim oAccess As Object Const sClasseAccess$ = "Access.Application" If False = bCreerObjet(oAccess, sClasseAccess) Then Exit Sub If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 oAccess.OpenCurrentDatabase sCheminBd ' Ouvrir le fichier Rapport pour ajout Dim oFSO As Object, oFile As Object Const sClasseScriptFSO$ = "Scripting.FileSystemObject" If False = bCreerObjet(oFSO, sClasseScriptFSO) Then Exit Sub Const ForAppending& = 8 Set oFile = oFSO.OpenTextFile(sCheminRapport, ForAppending) Dim refObj As Object If Me.ChkTablesDonnees Then oFile.WriteLine vbCrLf oFile.WriteLine "Tables :" Dim iNumTable% iNumTable = 0 For Each refObj In oAccess.CurrentDb.TableDefs ' Ignorer les tables systèmes If Left(refObj.Name, 4) <> "MSys" Then iNumTable = iNumTable + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acTable, sTypeObjetTable, iNumTable End If Next refObj End If If Me.ChkRq Then oFile.WriteLine vbCrLf oFile.WriteLine sTitreDefRq Dim iNumRq% iNumRq = 0 For Each refObj In oAccess.CurrentDb.QueryDefs If Left$(refObj.Name, 1) <> "~" Then iNumRq = iNumRq + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acQuery, sTypeObjetRequete, iNumRq End If Next refObj oFile.WriteLine vbCrLf oFile.WriteLine sTitreRqSys iNumRq = 0 For Each refObj In oAccess.CurrentDb.QueryDefs If Left$(refObj.Name, 1) = "~" Then iNumRq = iNumRq + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acQuery, sTypeObjetRequeteSys, iNumRq End If Next refObj End If If Me.ChkFrm Then oFile.WriteLine vbCrLf oFile.WriteLine "Formulaires :" Dim iNumFrm% iNumFrm = 0 For Each refObj In oAccess.CurrentProject.AllForms iNumFrm = iNumFrm + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acForm, sTypeObjetFormulaire, iNumFrm Next refObj End If If Me.ChkEtats Then oFile.WriteLine vbCrLf oFile.WriteLine "Etats :" Dim iNumEtat% iNumEtat = 0 For Each refObj In oAccess.CurrentProject.AllReports iNumEtat = iNumEtat + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acReport, sTypeObjetEtat, iNumEtat Next refObj End If If Me.ChkMacros Then oFile.WriteLine vbCrLf oFile.WriteLine "Macros :" Dim iNumMacro% iNumMacro = 0 For Each refObj In oAccess.CurrentProject.AllMacros iNumMacro = iNumMacro + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acMacro, sTypeObjetMacro, iNumMacro Next refObj End If If Me.ChkMod Then oFile.WriteLine vbCrLf oFile.WriteLine "Modules :" Dim iNumModule% iNumModule = 0 For Each refObj In oAccess.CurrentProject.AllModules iNumModule = iNumModule + 1 ExporterObjAccess0 oAccess, oFile, refObj, oFSO, sCheminTxtTmp, _ acModule, sTypeObjetModule, iNumModule Next refObj End If oAccess.CloseCurrentDatabase oAccess.Quit oFile.Close Fin: Set oAccess = Nothing Set oFSO = Nothing Exit Sub Erreur: Me.MousePointer = vbDefault AfficherMsgErreur Err, "ExporterObjAccess" Resume Fin End Sub Private Sub ExporterObjAccess0(ByRef oAccess As Object, _ ByRef oFile As Object, ByRef refObj As Object, ByRef oFSO As Object, _ ByVal sCheminTxtTmp$, ByVal lTypeObjet&, ByVal sTypeObjet$, _ Optional ByVal iNumObj%) AfficherMsg "Export en cours : " & sTypeObjet & " : " & refObj.Name & "..." If lTypeObjet = acTable Then Const acExportDelim& = 2 oAccess.DoCmd.TransferText acExportDelim, , refObj.Name, sCheminTxtTmp, _ HasFieldNames:=True Else oAccess.SaveAsText lTypeObjet, refObj.Name, sCheminTxtTmp End If ' Ouvrir le fichier créé Dim oFileTmp As Object Set oFileTmp = oFSO.OpenTextFile(sCheminTxtTmp) oFile.WriteLine vbCrLf Dim sAffichage$ sAffichage = sTypeObjet & " : " & refObj.Name If bMDB2Txt Then Dim sPrefixe$ sPrefixe = "" If sTypeObjet = sTypeObjetTable Then sPrefixe = sPrefixeTableDef If sTypeObjet = sTypeObjetModule Then sPrefixe = sPrefixeModuleDef If sTypeObjet = sTypeObjetFormulaire Then sPrefixe = sPrefixeFormDef If sTypeObjet = sTypeObjetEtat Then sPrefixe = sPrefixeEtatDef If sTypeObjet = sTypeObjetRequete Then sPrefixe = sPrefixeDefRqDef If sTypeObjet = sTypeObjetRequeteSys Then sPrefixe = sPrefixeRqSysDef If sTypeObjet = sTypeObjetMacro Then sPrefixe = sPrefixeMacroDef If iNumObj > 0 And Len(sPrefixe) > 0 Then sAffichage = sPrefixe & iNumObj & " : " & refObj.Name End If End If oFile.WriteLine sAffichage oFile.WriteLine vbCrLf ' Transférer le fichier créé dans le rapport global oFile.WriteLine oFileTmp.ReadAll oFileTmp.Close oFSO.DeleteFile sCheminTxtTmp End Sub Private Sub ListerObjBd(ByRef refBd As DAO.Database, ByVal lNumFichier&, _ Optional ByVal bListerProp As Boolean = False, _ Optional ByVal sTypeObjet$ = "ALL") ' Lister les objets DAO de base de données Access, avec leur propriétés ' D'après la source : ' From Access 97 Developer's Handbook ' by Litwin, Getz, Gilbert (Sybex) ' Copyright 1997. All rights reserved. ' List contents of containers, all or selected. ' Get lists of properties, too, if requested. ' In: ' bListerProp: (optional, default is False) ' If True, list properties for all objects ' sTypeObjet: (optional, default is "ALL") ' Leave blank for "ALL", or one of ' "Databases", "Forms", "Modules", "Relationships" ' "Reports", "Scripts", "SysRel", "Tables" Dim refCont As DAO.Container, refDoc As DAO.Document, refProp As DAO.Property ' Certaines propriétés ne peuvent être lues If bListerProp Then On Error Resume Next Print #lNumFichier, "" Print #lNumFichier, "" Print #lNumFichier, sTitreProprietesTous For Each refCont In refBd.Containers If sTypeObjet = "ALL" Or (sTypeObjet = refCont.Name) Then Print #lNumFichier, refCont.Name For Each refDoc In refCont.Documents Print #lNumFichier, , refDoc.Name If bListerProp Then For Each refProp In refDoc.Properties Print #lNumFichier, , , refProp.Name, refProp.Value Next refProp End If Next refDoc End If Next refCont If bListerProp Then On Error GoTo 0 End Sub Private Function DAODataTypeEnumToString$(ByVal elTipo As DataTypeEnum, _ Optional ByRef sTaille$ = "") ' Convertir en chaîne le type DAO ' D'après tipoToString : Devuelve una cadena según el tipo de datos (05/Nov/00) Dim s$, bAfficherTaille As Boolean bAfficherTaille = False Select Case elTipo Case dbBigInt: s = "dbBigInt" Case dbBinary: s = "dbBinary" Case dbBoolean: s = "dbBoolean" Case dbByte: s = "dbByte" Case dbChar: s = "dbChar" Case dbCurrency: s = "dbCurrency" Case dbDate: s = "dbDate" Case dbDecimal: s = "dbDecimal" Case dbDouble: s = "dbDouble" Case dbFloat: s = "dbFloat" Case dbGUID: s = "dbGUID" Case dbInteger: s = "dbInteger" Case dbLong: s = "dbLong" Case dbLongBinary: s = "dbLongBinary" Case dbMemo: s = "dbMemo" Case dbNumeric: s = "dbNumeric" Case dbSingle: s = "dbSingle" Case dbText: s = "dbText": bAfficherTaille = True Case dbTime: s = "dbTime" Case dbTimeStamp: s = "dbTimeStamp" Case dbVarBinary: s = "dbVarBinary" Case Else: s = "dbMemo" End Select s = Mid$(s, 3) ' Enlever db If bAfficherTaille Then s = s & sTaille DAODataTypeEnumToString = s End Function Public Function bCreerRapportBD_ODBC(ByVal sCheminBaseDonnees$, _ ByRef sCheminRapport$, _ Optional ByVal bConfirm As Boolean = True, _ Optional ByVal sCheminBaseSecurite$ = "", _ Optional ByVal sNomCompteUtilisateur$ = "", _ Optional ByVal sPwdCompteUtilisateur$ = "") As Boolean If sCheminBaseDonnees = "" Then Exit Function If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 sCheminRapport = Left$(sCheminBaseDonnees, Len(sCheminBaseDonnees) - 3) & "txt" Dim sMsg$ sMsg = "Voulez-vous créer le rapport de base de données suivant :" & vbLf & sCheminRapport & " ?" If bConfirm Then If vbYes <> MsgBox(sMsg, vbQuestion + vbYesNoCancel, sTitreMsg) Then _ Exit Function Me.MousePointer = vbHourglass AfficherMsg "Ouverture de la connexion ODBC en cours..." Dim oConn As New ADODB.Connection Dim oRq As New ADODB.Recordset Dim oRq2 As New ADODB.Recordset oConn.Mode = adModeRead Dim sConnexion$ sConnexion = "FILEDSN=" & sCheminBaseDonnees oConn.Open sConnexion AfficherMsg "Création du rapport de base de données en cours..." Dim sNomTable$, lNumFichier&, sDescriptionTable$ ' Doc : www.devguru.com/Technologies/ado/quickref/connection_openschema.html ' Mettre Table pour ne filtrer que les tables 'Set oRq = oConn.OpenSchema(adSchemaTables, Array(Empty, Empty, Empty, "Table")) Set oRq = oConn.OpenSchema(adSchemaTables) ' Tables et Rq lNumFichier = FreeFile Open sCheminRapport For Output Access Write Lock Read Write As lNumFichier Print #lNumFichier, _ "Rapport de base de données DBComp : www.vbfrance.com/code.aspx?ID=17847" Print #lNumFichier, _ "Par Patrice Dargenton : http://patrice.dargenton.free.fr/index.html" Print #lNumFichier, _ "Base de données : " & sCheminBaseDonnees If Me.ChkTypesChamps Then _ Print #lNumFichier, "Affichage des types des champs via ODBC : à finir !" If Me.ChkIndex Then _ Print #lNumFichier, "Affichage des index via ODBC : à finir !" If Me.ChkTablesLiees Then _ Print #lNumFichier, "Affichage des tables liées via ODBC : à finir !" If Me.ChkRequetes Then _ Print #lNumFichier, "Affichage des requêtes via ODBC : à finir !" ' Parcourir toutes les tables de la base de données While Not oRq.EOF sNomTable = oRq!TABLE_NAME 'tdTable.Name ' Ignorer les tables systèmes If Left(sNomTable, 4) = "MSys" Then GoTo TableSuivante ' Ignorer les requêtes pour le moment If oRq!TABLE_TYPE <> "TABLE" Then GoTo TableSuivante 'Si oRq!TABLE_TYPE = "VIEW" : Requete 'oRq!TABLE_CATALOG : Chemin de la base 'oRq!TABLE_SCHEMA : cf. modADOProp 'Table type. One of the following or a provider-specific value. '"ALIAS" '"TABLE" '"SYNONYM" '"SYSTEM TABLE" '"VIEW" '"GLOBAL TEMPORARY" '"LOCAL TEMPORARY" 'TABLE_CATALOG 'TABLE_SCHEMA 'TABLE_NAME 'TABLE_TYPE 'TABLE_GUID 'DESCRIPTION 'TABLE_PROPID 'DATE_CREATED : à tester ! 'DATE_MODIFIED : à tester ! Print #lNumFichier, "" ' Saut de ligne 'sDescriptionTable = "(null : bug ADO ?)" sDescriptionTable = "(Description : non supporté via ADO/ODBC)" ' Ne marche pas avec Access : If Not IsNull(oRq!Description) Then _ sDescriptionTable = oRq!Description Print #lNumFichier, sNomTable & " : " & sDescriptionTable 'Print #lNumFichier, sNomTable '& " : " & oRq!TABLE_SCHEMA ' Récupérer les champs de la table 'Set oRq2 = oConn.OpenSchema(QueryType, Criteria, SchemaID) Set oRq2 = oConn.OpenSchema(adSchemaColumns, _ Array(Empty, Empty, sNomTable)) Dim sDescription$ While Not oRq2.EOF sDescription = "(null)" If Not IsNull(oRq2!Description) Then _ sDescription = oRq2!Description Print #lNumFichier, " " & oRq2!COLUMN_NAME & " : " & sDescription oRq2.MoveNext Wend oRq2.Close ' Récupérer les index de la table : à finir : cf. modADOProp 'adSchemaIndexes TableSuivante: oRq.MoveNext Wend oRq.Close ' Récupérer les requêtes de la bd : à finir ' Récupérer les propriétés : ne trouve que les celles de la connexion If Me.ChkProp Then ListerPropADO oConn, lNumFichier Me.MousePointer = vbDefault AfficherMsg "" If bConfirm Then sMsg = "Création du rapport de base de données terminée :" & vbLf & sCheminRapport MsgBox sMsg, vbExclamation, sTitreMsg End If bCreerRapportBD_ODBC = True Fin: On Error Resume Next 'Close lNumFichier Close ' Fermer tous les fichiers ouverts If Not oConn Is Nothing Then _ If (oConn.State And adStateOpen) = adStateOpen Then oConn.Close If Not oRq Is Nothing Then _ If (oRq.State And adStateOpen) = adStateOpen Then oRq.Close If Not oRq2 Is Nothing Then _ If (oRq2.State And adStateOpen) = adStateOpen Then oRq2.Close Set oConn = Nothing Set oRq = Nothing Set oRq2 = Nothing AfficherMsg "" Me.MousePointer = vbDefault Exit Function Erreur: Me.MousePointer = vbDefault AfficherMsgErreur Err, "bCreerRapportBD_ODBC" Resume Fin End Function Private Sub CmdTestODBC_Click() ' Générer des fichiers dsn avec un chemin relatif correct ' pour faire une démo qui marche immédiatement If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 Dim sCheminCourant$ sCheminCourant = App.Path Const iNumFichier% = 1 Dim sFichierDSN1$, sFichierDSN2$ sFichierDSN1 = sCheminCourant & "\" & sFichierDsn_MSAccess_BD1 Open sFichierDSN1 For Output Access Write Lock Read Write As #iNumFichier Print #iNumFichier, "[ODBC]" Print #iNumFichier, "DRIVER=Microsoft Access Driver (*.mdb)" Print #iNumFichier, "UID=admin" Print #iNumFichier, "UserCommitSync=Yes" Print #iNumFichier, "Threads=3" Print #iNumFichier, "SafeTransactions=0" Print #iNumFichier, "PageTimeout=5" Print #iNumFichier, "MaxScanRows=8" Print #iNumFichier, "MaxBufferSize=2048" Print #iNumFichier, "FIL=MS Access" Print #iNumFichier, "DriverId=25" Print #iNumFichier, "DefaultDir=" & sCheminCourant Print #iNumFichier, "DBQ=" & sCheminCourant & "\DVDClassV1.mdb" Close #iNumFichier sFichierDSN2 = sCheminCourant & "\" & sFichierDsn_MSAccess_BD2 Open sFichierDSN2 For Output Access Write Lock Read Write As #iNumFichier Print #iNumFichier, "[ODBC]" Print #iNumFichier, "DRIVER=Microsoft Access Driver (*.mdb)" Print #iNumFichier, "UID=admin" Print #iNumFichier, "UserCommitSync=Yes" Print #iNumFichier, "Threads=3" Print #iNumFichier, "SafeTransactions=0" Print #iNumFichier, "PageTimeout=5" Print #iNumFichier, "MaxScanRows=8" Print #iNumFichier, "MaxBufferSize=2048" Print #iNumFichier, "FIL=MS Access" Print #iNumFichier, "DriverId=25" Print #iNumFichier, "DefaultDir=" & sCheminCourant Print #iNumFichier, "DBQ=" & sCheminCourant & "\DVDClassV2.mdb" Close #iNumFichier MsgBox "2 fichiers .dsn pour 2 sources ODBC MS-Access ont été créés" & vbLf & _ "avec les chemins en local :" & vbLf & _ sFichierDSN1 & vbLf & sFichierDSN2, vbExclamation, sTitreMsg Me.TxtBD1 = sFichierDSN1 Me.TxtBD2 = sFichierDSN2 Fin: Close ' Fermer tous les fichiers ouverts Exit Sub Erreur: AfficherMsgErreur Err, "CmdTestODBC" Resume Fin End Sub Public Function bSupprimerEnreg(ByVal sCheminBaseDonnees$, _ Optional ByVal bConfirm As Boolean = True, _ Optional ByVal sCheminBaseSecurite$ = "", _ Optional ByVal sNomCompteUtilisateur$ = "", _ Optional ByVal sPwdCompteUtilisateur$ = "") As Boolean ' Algorithme : Supprimer tous les enregistrements de toutes les tables ; ' recommencer tant qu'il reste des enregistrements (qui n'ont pas encore ' pu être supprimés à cause des contraintes d'effacement en cascade) Dim sMsg$ If bConfirm Then sMsg = "Etes-vous sûr de vouloir supprimer tous les enregistrements de :" & vbLf & _ sCheminBaseDonnees & " ?" If vbYes <> MsgBox(sMsg, vbQuestion + vbYesNoCancel, sTitreMsg) Then Exit Function End If Dim oBd As DAO.Database, oSession As DAO.Workspace If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 AfficherMsg "Suppression en cours..." If sNomCompteUtilisateur = "" Or sCheminBaseSecurite = "" Then ' Ouverture de la base avec le compte admin standard DAO.DBEngine.SystemDB = "" Set oSession = DAO.DBEngine.Workspaces(0) Else ' Ouverture de la base avec un compte sécurisé par mot de passe ' New est une session temporaire DAO.DBEngine.SystemDB = sCheminBaseSecurite Set oSession = DAO.DBEngine.CreateWorkspace("New", _ sNomCompteUtilisateur, sPwdCompteUtilisateur) End If Set oBd = oSession.OpenDatabase(sCheminBaseDonnees) Dim refTable As DAO.TableDef, oQd As DAO.QueryDef, oRq As DAO.Recordset, sSQL$ Dim bRecommencer As Boolean, lNbEnregSupprimes& ' Boucle sur les tables Recommencer: bRecommencer = False lNbEnregSupprimes = 0 For Each refTable In oBd.TableDefs ' Ne pas supprimer les tables systèmes If Left(refTable.Name, 4) = "MSys" Then GoTo TableSuivante ' Ne pas supprimer les tables liées If refTable.Connect <> "" Then GoTo TableSuivante ' Crée un objet QueryDef temporaire pour la suppression des enreg. Set oQd = oBd.CreateQueryDef("", "DELETE * FROM [" & refTable.Name & "]") oQd.Execute lNbEnregSupprimes = lNbEnregSupprimes + oQd.RecordsAffected oQd.Close TableSuivante: Next refTable For Each refTable In oBd.TableDefs If Left(refTable.Name, 4) = "MSys" Then GoTo TableSuivante2 If refTable.Connect <> "" Then GoTo TableSuivante2 ' Vérification s'il reste des enreg. sSQL = "SELECT * FROM [" & refTable.Name & "]" Set oRq = oBd.OpenRecordset(sSQL, dbOpenForwardOnly) If Not (oRq.EOF And oRq.BOF) Then bRecommencer = True: oRq.Close: Exit For End If oRq.Close TableSuivante2: Next refTable If bRecommencer Then If lNbEnregSupprimes = 0 Then MsgBox "Impossible de supprimer les enreg. de " & _ sCheminBaseDonnees, vbCritical, sTitreMsg GoTo Fin End If GoTo Recommencer End If AfficherMsg "" If bConfirm Then sMsg = "Suppression de tous les enregistrements terminée :" & vbLf & _ sCheminBaseDonnees MsgBox sMsg, vbExclamation, sTitreMsg End If bSupprimerEnreg = True Fin: On Error Resume Next If Not (oRq Is Nothing) Then oRq.Close If Not (oQd Is Nothing) Then oQd.Close If Not (oBd Is Nothing) Then oBd.Close If Not (oSession Is Nothing) Then oSession.Close AfficherMsg "" Exit Function Erreur: AfficherMsgErreur Err, "bSupprimerEnreg" Resume Fin End Function modADOProp (modADOProp.bas) Option Explicit ' D'après le Guide du programmeur Microsoft Office 2000/Visual Basic. Public Sub ListerPropADO(ByRef refConn As ADODB.Connection, ByVal lNumFichier&) Print #lNumFichier, "" Print #lNumFichier, "Propriétés :" PrintConnectionProperties refConn, lNumFichier ' Aucune propriété n'est trouvée ? 'PrintTableProperties refConn, lNumFichier End Sub Private Sub PrintConnectionProperties(ByRef refConn As ADODB.Connection, ByVal lNumFichier&) Print #lNumFichier, "" Print #lNumFichier, "Propriétés de la connexion :" Dim refProp As ADODB.Property For Each refProp In refConn.Properties Print #lNumFichier, refProp.Name & " = " & refProp.Value Next End Sub Private Sub PrintCommandProperties() Dim cnnDB As ADODB.Connection Dim cmd As ADODB.Command Dim prpProp As ADODB.Property ' Définit l'objet Connection pour utiliser la base de données ' Access en cours. 'Set cnnDB = CurrentProject.Connection Set cmd = New ADODB.Command Set cmd.ActiveConnection = cnnDB cmd.CommandText = "SELECT * FROM Categories" For Each prpProp In cmd.Properties Debug.Print prpProp.Name & " = " & prpProp.Value Next Set cnnDB = Nothing End Sub Private Sub PrintRecordsetProperties() Dim cnnDB As ADODB.Connection Dim rst As ADODB.Recordset Dim prpProp As ADODB.Property ' Définit l'objet Connection pour utiliser la base de données ' Access en cours. 'Set cnnDB = CurrentProject.Connection Set rst = New ADODB.Recordset rst.Open "Orders", cnnDB, adOpenKeyset, _ adLockOptimistic, adCmdTableDirect For Each prpProp In rst.Properties Debug.Print prpProp.Name & " = " & prpProp.Value Next rst.Close Set rst = Nothing Set cnnDB = Nothing End Sub Private Sub PrintFieldProperties() Dim cnnDB As ADODB.Connection Dim rst As ADODB.Recordset Dim fld As ADODB.Field Dim prpProp As ADODB.Property ' Définit l'objet Connection pour utiliser la base de données ' Access en cours. 'Set cnnDB = CurrentProject.Connection Set rst = New ADODB.Recordset rst.Open "Orders", cnnDB, adOpenKeyset, _ adLockOptimistic, adCmdTableDirect Set fld = rst.Fields("OrderID") For Each prpProp In fld.Properties Debug.Print prpProp.Name & " = " & prpProp.Value Next rst.Close Set rst = Nothing Set cnnDB = Nothing End Sub ' Library ADOX ' C:\Program Files\Fichiers communs\System\ado\msADOX.dll ' Microsoft ADO Ext. 2.8 for DDL and Security 'Private Sub PrintTableProperties(ByVal refConn As ADODB.Connection, ByVal lNumFichier&) ' Print #lNumFichier, "" ' Print #lNumFichier, "Propriétés des tables :" ' Dim oCat As ADOX.Catalog ' Dim refTable As ADOX.Table ' Dim refProp As ADOX.Property ' oCat = New ADOX.Catalog ' oCat.ActiveConnection = refConn ' For Each refTable In oCat.Tables ' Print #lNumFichier, , "" ' Print #lNumFichier, , "Table :" & refTable.Name ' For Each refProp In refTable.Properties ' Print #lNumFichier, , , refProp.Name & " = " & refProp.Value ' Next refProp ' Next refTable ' oCat = Nothing 'End Sub 'Private Sub PrintTableProperties_() ' Dim catDB As ADOX.Catalog ' Dim tbl As ADOX.Table ' Dim prpProp As ADOX.Property ' catDB = New ADOX.Catalog ' ' Définit l'objet Connection pour utiliser la base de données ' ' Access en cours. ' 'catDB.ActiveConnection = CurrentProject.Connection ' tbl = catDB.Tables("Order Details") ' For Each prpProp In tbl.Properties ' Debug.Print(prpProp.Name & " = " & prpProp.Value) ' Next ' catDB = Nothing 'End Sub 'Private Sub PrintIndexProperties() ' Dim catDB As ADOX.Catalog ' Dim idx As ADOX.Index ' Dim prpProp As ADOX.Property ' catDB = New ADOX.Catalog ' ' Définit l'objet Connection pour utiliser la base de données ' ' Access en cours. ' 'catDB.ActiveConnection = CurrentProject.Connection ' idx = catDB.Tables("Categories").Indexes("PrimaryKey") ' For Each prpProp In idx.Properties ' Debug.Print(prpProp.Name & " = " & prpProp.Value) ' Next ' catDB = Nothing 'End Sub 'Private Sub PrintColumnProperties() ' Dim catDB As ADOX.Catalog ' Dim clm As ADOX.Column ' Dim prpProp As ADOX.Property ' catDB = New ADOX.Catalog ' ' Définit l'objet Connection pour utiliser la base de données ' ' Access en cours. ' 'catDB.ActiveConnection = CurrentProject.Connection ' clm = catDB.Tables("Employees").Columns("BirthDate") ' For Each prpProp In clm.Properties ' Debug.Print(prpProp.Name & " = " & prpProp.Value) ' Next ' catDB = Nothing 'End Sub modSelectionFichier (modSelectionFichier.bas) Option Explicit ' Sélection d'un fichier (à cause de la limite du MSComDlg.CommonDialog) Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _ "GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long Private Type OPENFILENAME lStructSize As Long hwndOwner As Long hInstance As Long lpstrFilter As String lpstrCustomFilter As String nMaxCustFilter As Long nFilterIndex As Long lpstrFile As String nMaxFile As Long lpstrFileTitle As String nMaxFileTitle As Long lpstrInitialDir As String lpstrTitle As String flags As Long nFileOffset As Integer nFileExtension As Integer lpstrDefExt As String lCustData As Long lpfnHook As Long lpTemplateName As String End Type Public Function bChoisirUnFichierAPI(ByRef sFichier$, ByVal sFiltre$, ByVal sTitre$, _ ByVal sInitDir$, ByVal lHandelWnd&) As Boolean Dim OpenFile As OPENFILENAME Dim lRet& OpenFile.lStructSize = Len(OpenFile) OpenFile.hwndOwner = lHandelWnd OpenFile.lpstrFilter = sFiltre OpenFile.nFilterIndex = 1 OpenFile.lpstrFile = String(257, 0) OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1 OpenFile.lpstrFileTitle = OpenFile.lpstrFile OpenFile.nMaxFileTitle = OpenFile.nMaxFile ' Ne pas réinitialiser le répertoire par défaut si on ne le demande pas If sInitDir <> "" Then OpenFile.lpstrInitialDir = sInitDir OpenFile.lpstrTitle = sTitre OpenFile.flags = &H1000 ' FileMustExist (OFN_FILEMUSTEXIST) lRet = GetOpenFileName(OpenFile) If lRet = 0 Then sFichier = "" Else sFichier = Trim$(OpenFile.lpstrFile) ' Enlever les caractères null à la fin Dim iPos% iPos = InStr(sFichier, vbNullChar) If iPos Then sFichier = Left(sFichier, iPos - 1) bChoisirUnFichierAPI = True End If End Function Public Function bChoisirUnFichier(ByRef sFichier$) As Boolean Dim oDLG As Object ' Ce contrôle ne marche que si VB6 est installé sur le poste client ' c'est une (idiote) restriction de licence On Error GoTo Erreur 'Err.Raise 429 ' Test traitement d'err si VB6 n'est pas installé Set oDLG = CreateObject("MSComDlg.CommonDialog") With oDLG .InitDir = App.Path .DialogTitle = "Choisir une base de données Access" .Filter = "Base de données MS-Access (*.mdb)|*.mdb" .MaxFileSize = 255 .flags = .flags Or &H1000 ' FileMustExist (OFN_FILEMUSTEXIST) .ShowOpen If .FileName <> "" Then sFichier = .FileName: bChoisirUnFichier = True End With Set oDLG = Nothing Exit Function Erreur: If Err = 429 Then AfficherMsgErreur Err, "bChoisirUnFichier", _ "L'environnement Visual Basic 6 ou Visual Studio 6 est requis", _ "Il n'y a pas de licence valide pour ce contrôle" Else AfficherMsgErreur Err, "bChoisirUnFichier" End If Err.Clear End Function modUtilitaires (modUtil.bas) Option Explicit Public Const sTitreMsg$ = "DBComp" Public Function asArgLigneCmd(ByVal sFichiers$) As String() ' Retourner les arguments de la ligne de commande Dim iNbArg%, asArgs$() Dim sGm$, sFichier$, sSepar$, bNomLong As Boolean sGm = Chr$(34) ' Guillemets 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quelque soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : " ' une fois le nom traité, les guillemets sont enlevé ' S'il y a un non court parmi eu, il n'est pas entre guillemets Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2%, bFin As Boolean sCmd = sFichiers 'Command$ iLen = Len(sCmd) iDeb = 1 Do bNomLong = False: sSepar = " " ' Si le premier caractère est un guillement, c'est un nom long If Mid$(sCmd, iDeb, 1) = sGm Then bNomLong = True: sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong Then iDeb2 = iDeb2 + 1 ' Bug corrigé : iDeb2 + 1 et non iDeb2 + 2 iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True: iFin = iLen + 1 sFichier = Trim$(Mid$(sCmd, iDeb2, iFin - iDeb2)) If sFichier <> "" Then ReDim Preserve asArgs(iNbArg) asArgs(iNbArg) = sFichier iNbArg = iNbArg + 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop asArgLigneCmd = asArgs End Function Public Function bTableauVide(ByRef aString$()) As Boolean ' Renvoyer True si le tableau est vide On Error Resume Next Dim iArgMin% iArgMin = LBound(aString()) If Err > 0 Then bTableauVide = True On Error GoTo 0 Err.Clear End Function Public Function bFichierExiste(ByVal sCheminFichier$) As Boolean ' Retourner l'existence ou non d'un fichier avec un chemin complet On Error Resume Next bFichierExiste = (Len(Dir$(sCheminFichier)) > 0) If Err <> 0 Then bFichierExiste = False End Function Public Function bSupprimerFichier(ByVal sCheminFichier$) As Boolean ' Vérifier si le fichier existe If False = bFichierExiste(sCheminFichier) Then _ bSupprimerFichier = True: Exit Function On Error Resume Next ' Impossible de supprimer à cause d'un verrou Kill sCheminFichier Err.Clear: On Error GoTo 0 If bFichierExiste(sCheminFichier) Then MsgBox "Impossible de supprimer le fichier :" & vbLf & _ sCheminFichier & vbLf & _ "Cause possible : le fichier est ouvert avec un logiciel", _ vbCritical, sTitreMsg Exit Function End If bSupprimerFichier = True End Function Public Function sExtraireChemin$(ByVal sFichier$, _ Optional ByRef sNomFichier$ = "") ' Retourner le chemin du fichier passé en argument ' non compris le caractère \ ' Retourner aussi le nom du fichier sans le chemin If sFichier = "" Then Exit Function Dim sChemin$, lTaille%, i%, sCar$ lTaille = Len(sFichier) For i = lTaille To 1 Step -1 sCar = Mid$(sFichier, i, 1) If sCar = "\" Or sCar = ":" Then sChemin = Left$(sFichier, i - 1) sNomFichier = Mid$(sFichier, i + 1) Exit For End If Next i sExtraireChemin = sChemin End Function Public Sub AfficherMsgErreur(ByRef Erreur As Object, Optional ByVal sTitreFct$ = "", _ Optional ByVal sInfo$ = "", Optional ByVal sDetailMsgErr$ = "") Const vbDefault% = 0 If Screen.MousePointer <> vbDefault Then Screen.MousePointer = vbDefault Dim sMsg$ If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg = sMsg & vbCrLf & sInfo If Erreur.Number Then sMsg = sMsg & vbCrLf & "Err n°" & Str$(Erreur.Number) & " :" sMsg = sMsg & vbCrLf & Erreur.Description End If If sDetailMsgErr <> "" Then sMsg = sMsg & vbCrLf & sDetailMsgErr MsgBox sMsg, vbCritical, sTitreMsg End Sub Public Function bIndexRelation(ByRef refBd As DAO.Database, ByVal sIndex$) As Boolean ' Reconnaitre les index qu'Access ajoute lorsque l'on créé une relation entre ' deux tables. Dans ce cas le nom de l'index n'est pas entre accolades, et il ' n'apparait pas dans la liste des index de la table dans l'interface utilisateur. ' Cependant, si l'index figure dans la table système MSysRelationships dans le ' champ szRelationship, alors c'est un index de relation : Cette table n'est pas ' accessible en SQL depuis l'exterieur (table système), mais elle expose son ' contenu via les propriétés de la base Dim refDoc As DAO.Document On Error Resume Next Set refDoc = refBd.Containers("Relationships").Documents(sIndex) ' Err. n°3265 : Élément non trouvé dans cette collection. If Err = 3265 Then GoTo Fin If Err > 0 Then AfficherMsgErreur Err, "bIndexRelation": GoTo Fin bIndexRelation = True Fin: On Error GoTo 0 End Function Public Function bCreerObjet(ByRef oObjetQcq As Object, sClasse$) As Boolean ' Attention, avec Outlook, le CreateObject fait plutôt un GetObject ' (si l'appli était déjà ouverte, elle disparait), voir bCreerObjet2 On Error Resume Next Set oObjetQcq = CreateObject(sClasse) If Err <> 0 Then AfficherMsgErreur Err, "bCreerObjet", _ "L'objet de classe [" & sClasse & "] ne peut pas être créé", vbCritical Err.Clear: Set oObjetQcq = Nothing: GoTo Fin End If bCreerObjet = True Fin: On Error GoTo 0 End Function