AccessBackup v1.0.3.*Table des procédures 1 - AssemblyInfo.vb 2 - modDepart.vb 2.1 - Public Sub Main 3 - modConst.vb 4 - frmAccessBackup.vb 4.1 - Private Function bArchiver 4.2 - Private Function bRoulement 4.3 - Private Sub AfficherMsg 4.4 - Private Sub Backup 4.5 - Private Sub frmAccessBackup_Load 4.6 - Private Sub timerDebut_Tick 4.7 - Private Sub timerFin_Tick 4.8 - Private Sub TracerExecution 4.9 - Public Sub Sablier 4.10 - Public WriteOnly Property bCompactRepair 4.11 - Public WriteOnly Property iNbVersionsRoulement% 4.12 - Public WriteOnly Property iPeriodeArchJours% 4.13 - Public WriteOnly Property sCheminSrc$ 4.14 - Public WriteOnly Property sCheminTrace$ 4.15 - Public WriteOnly Property sDossierSauvegardes$ 4.16 - Public WriteOnly Property sDossierSauvegardesIncert$ 4.17 - Public WriteOnly Property sFormatVersionsArch$ 4.18 - Public WriteOnly Property sFormatVersionsRoulement$ 4.19 - Public WriteOnly Property sMotDePasse$ 4.20 - Public WriteOnly Property sSuffixeArchive$ 4.21 - Public WriteOnly Property sSuffixeBdFermee$ 4.22 - Public WriteOnly Property sSuffixeBdOuverte$ 4.23 - Public WriteOnly Property sSuffixeBdOuverteCompactee$ 4.24 - Public WriteOnly Property sSuffixeCopie$ 5 - modUtil.vb 5.1 - Public Function asArgLigneCmd 5.2 - Public Function bAppliDejaOuverte 5.3 - Public Function bCreerObjet 5.4 - Public Function iConvertir% 5.5 - Public Function sFormater$ 5.6 - Public Sub AfficherMsgErreur 5.7 - Public Sub AfficherMsgErreur2 5.8 - Public Sub CopierPressePapier 6 - modUtilDAO.vb 6.1 - Private Sub AfficherErreursADO 6.2 - Public Function iNbUtilisateurs% 6.3 - Public Function oNz 7 - modUtilDAO2.vb 7.1 - Public Function bCompacterMdb 8 - modUtilFichier.vb 8.1 - Public Function bCopierFichier 8.2 - Public Function bDossierExiste 8.3 - Public Function bFichierExiste 8.4 - Public Function bRenommerFichier 8.5 - Public Function bSupprimerFichier 8.6 - Public Function bVerifierCreerDossier 8.7 - Public Function sDeduireChemin$ 8.8 - Public Function sDossierRacine$ 9 - modZip.vb 9.1 - Public Function bZipper AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- Imports System Imports System.Reflection Imports System.Runtime.InteropServices <Assembly: AssemblyTitle("AccessBackup")> <Assembly: AssemblyDescription( _ "AccessBackUp : Un gestionnaire de sauvegarde de base de données Access")> <Assembly: AssemblyCompany("ORS Production")> <Assembly: AssemblyProduct("AccessBackup")> <Assembly: AssemblyCopyright("© 2013 ORS Production")> <Assembly: AssemblyTrademark("AccessBackup")> <Assembly: CLSCompliant(True)> ' Le GUID suivant est pour l'ID de la typelib si ce projet est exposé à COM <Assembly: Guid("DB2E7A2A-AE6E-47FD-A2AD-0B392B73E387")> <Assembly: AssemblyVersion("1.0.3.*")> modDepart.vb ' Fichier modDepart.vb ' -------------------- ' AccessBackUp : Un gestionnaire de sauvegarde de base de données Access ' http://www.vbfrance.com/code.aspx?ID=33732 ' Par Patrice Dargenton ' patrice.dargenton@free.fr ' http://patrice.dargenton.free.fr/index.html ' http://patrice.dargenton.free.fr/CodesSources/index.html ' http://www.vbfrance.com/listeauteur2.aspx?ID=1124 ' Documentation : AccessBackUp.html ' Version 1.03 du 16/03/2013 CompactRepair ' Version 1.02 du 01/11/2009 MotDePasse ' Version 1.01 du 10/09/2005 ' Conventions de nommage des variables : ' ------------------------------------ ' b pour Boolean (booléen vrai ou faux) ' i pour Integer : % (en VB .Net, l'entier a la capacité du VB6.Long) ' l pour Long : & ' r pour nombre Réel (Single!, Double# ou Decimal : D) ' s pour String : $ ' c pour Char ou Byte ' 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 ' ... ' ------------------------------------ Module modDepart Public Sub Main() ' Laisser la possibilité de lancer plusieurs backup avec le même exe ' mais avec des bases distinctes 'If bAppliDejaOuverte(bMemeExe:=True) Then Exit Sub ' On peut démarrer l'application sur la feuille, ou bien sur la procédure ' main() si on veut pouvoir détecter l'absence de la dll sans plantage If Not bFichierExiste(Application.StartupPath & "\ICSharpCode.SharpZipLib.dll", _ bPrompt:=True) Then Exit Sub If Not bFichierExiste(Application.StartupPath & "\adodb.dll", _ bPrompt:=True) Then Exit Sub ' Extraire les options passées en argument de la ligne de commande ' Ne fonctionne pas avec des chemins contenant des espaces, même entre guillemets 'Dim asArgs$() = Environment.GetCommandLineArgs() Dim sArg0$ = Microsoft.VisualBasic.Interaction.Command Dim sCheminSrc$ = sCheminSrcDef Dim sCheminTrace$ = sCheminTraceDef Dim sDossierSauvegardes$ = sDossierSauvegardesDef Dim sDossierSauvegardesIncert$ = "" Dim iPeriodeArchJours% = iPeriodeArchJoursDef Dim iNbVersionsRoulement% = iNbVersionsRoulementDef Dim sFormatVersionsRoulement$ = sFormatVersionsRoulementDef Dim sFormatVersionsArch$ = sFormatVersionsArchDef Dim sSuffixeArchive$ = sSuffixeArchiveDef Dim sSuffixeCopie$ = sSuffixeCopieDef Dim sSuffixeBdOuverte$ = sSuffixeBdOuverteDef Dim sSuffixeBdOuverteCompactee$ = sSuffixeBdOuverteCompacteeDef Dim sSuffixeBdFermee$ = sSuffixeBdFermeeDef Dim sMotDePasse$ = "" Dim bCompactRepair As Boolean = False If sArg0 <> "" Then Dim asArgs$() = asArgLigneCmd(sArg0) Dim iNbArg% = 1 + UBound(asArgs) If iNbArg = 1 Then ' 01/11/2009 Si un seul argument, on convient que c'est la bd à traiter sCheminSrc = asArgs(0) GoTo Suite End If Dim iNbPairsArg% = iNbArg \ 2 Dim iNumArg1% For iNumArg1 = 0 To iNbPairsArg - 1 Dim sCle$ = asArgs(iNumArg1 * 2) If iNumArg1 * 2 + 1 > iNbArg Then MsgBox("Erreur : Nombre impair d'arguments !" & vbCrLf & _ "Pensez à mettre entre guillemets les chemins contenant des espaces", _ MsgBoxStyle.Critical, sTitreMsg) Exit Sub End If Dim sVal$ = asArgs(iNumArg1 * 2 + 1) Select Case sCle.ToLower Case "CheminSrc".ToLower sCheminSrc = sVal Case "DossierSauvegardes".ToLower sDossierSauvegardes = sVal Case "DossierSauvegardesIncert".ToLower sDossierSauvegardesIncert = sVal Case "CheminTrace".ToLower sCheminTrace = sVal Case "SuffixeArchive".ToLower If sVal <> "" Then sSuffixeArchive = sVal Case "SuffixeCopie".ToLower If sVal <> "" Then sSuffixeCopie = sVal Case "SuffixeBdOuverte".ToLower If sVal <> "" Then sSuffixeBdOuverte = sVal Case "SuffixeBdOuverteCompactee".ToLower If sVal <> "" Then sSuffixeBdOuverteCompactee = sVal Case "SuffixeBdFermee".ToLower If sVal <> "" Then sSuffixeBdFermee = sVal Case "FormatVersionsRoulement".ToLower If sVal <> "" Then sFormatVersionsRoulement = sVal Case "FormatVersionsArch".ToLower If sVal <> "" Then sFormatVersionsArch = sVal Case "PeriodeArchJours".ToLower iPeriodeArchJours = iConvertir(sVal, iPeriodeArchJoursDef) Case "NbVersionsRoulement".ToLower iNbVersionsRoulement = iConvertir(sVal, iNbVersionsRoulementDef) Case "MotDePasse".ToLower ' 01/11/2009 sMotDePasse = sVal Case "CompactRepair".ToLower ' 16/03/2013 bCompactRepair = True sCheminSrc = sVal End Select Next iNumArg1 End If Suite: If sDossierSauvegardesIncert = "" Then _ sDossierSauvegardesIncert = sDossierSauvegardes Try Dim oFrm As frmAccessBackup oFrm = New frmAccessBackup oFrm.sCheminTrace = sCheminTrace oFrm.sCheminSrc = sCheminSrc oFrm.sDossierSauvegardes = sDossierSauvegardes oFrm.sDossierSauvegardesIncert = sDossierSauvegardesIncert oFrm.iPeriodeArchJours = iPeriodeArchJours oFrm.iNbVersionsRoulement = iNbVersionsRoulement oFrm.sFormatVersionsRoulement = sFormatVersionsRoulement oFrm.sFormatVersionsArch = sFormatVersionsArch oFrm.sSuffixeArchive = sSuffixeArchive oFrm.sSuffixeCopie = sSuffixeCopie oFrm.sSuffixeBdOuverte = sSuffixeBdOuverte oFrm.sSuffixeBdOuverteCompactee = sSuffixeBdOuverteCompactee oFrm.sSuffixeBdFermee = sSuffixeBdFermee oFrm.sMotDePasse = sMotDePasse oFrm.bCompactRepair = bCompactRepair ' Surtout pas ShowDialog : cela ne fonctionne pas si aucune session ' n'est ouverte : le code erreur de retour est affiché dans le ' planifieur de tâche : 0xe0434f4d au lieu de 0x0 ' ou sinon une boîte de dialogue peut s'afficher même sans session ouverte, ' avec le code d'erreur 0x800405a6 lié au deboguer JIT ' (ce bug fut difficile à trouver...) 'oFrm.ShowDialog() Application.Run(oFrm) Catch Ex As Exception If bDebug Then MsgBox("Erreur : " & Ex.Message & vbCrLf & Ex.Source, _ MsgBoxStyle.Critical, sTitreMsg) 'Catch ' (on ne peut pas mettre à la fois Catch Ex et Catch seul selon VB8) ' If bDebug Then MsgBox("Erreur non managée !", MsgBoxStyle.Critical, sTitreMsg) End Try End Sub End Module modConst.vb ' Fichier modConst.vb ' ------------------- Module modConst Public ReadOnly sNomAppli$ = My.Application.Info.Title ' AccessBackup 'Public sTitreMsg$ = sNomAppli Public Const sTitreMsg$ = "AccessBackup - Gestionnaire de sauvegarde" Private Const sDateVersionAB$ = "16/03/2013" Public Const sDateVersionAppli$ = sDateVersionAB ' Pour pouvoir localiser la ligne ayant provoqué une erreur, mettre bTrapErr = False ' Intercepter les erreurs (peu utilisé) Public Const bTrapErr As Boolean = True ' Mode Release = distribuable 'Public Const bTrapErr As Boolean = False ' Ne pas intercepter les erreurs ' Afficher toutes les boîtes de dialogue des erreurs Public Const bPromptErrGlob As Boolean = False Public Const bDebug As Boolean = False ' (peu utilisé) 'Public Const bDebug As Boolean = True ' Ignorer les dates en mode debug : ' sauvegarder même si la date d'écriture n'a pas changée Public Const bIgnorerDateMAJ As Boolean = False ' Tester le backup toutes les 10 secondes Public Const bBoucleInfinie As Boolean = False Public Const iDelaiLectureMsgMilliSec% = 5000 ' Suffixe pour la copie temporaire (autre que base Access) Public Const sSuffixeCopieTmp$ = "_CopieTmp" ' Suffixe pour la base compactée temporaire Public Const sSuffixeCompactTmp$ = "_CompactTmp" ' Valeurs par défaut : ' Suffixe pour la base ouverte non compactée (utile pour conserver sa date d'écriture) Public Const sSuffixeBdOuverteDef$ = "_CopieIncertOrig" ' Suffixe pour la base ouverte compactée Public Const sSuffixeBdOuverteCompacteeDef$ = "_CopieIncert" '"CopieNonSure" ' Suffixe pour la base fermée (et compactée) Public Const sSuffixeBdFermeeDef$ = "_CopieFiable" ' Suffixe pour la copie (autre que base Access) Public Const sSuffixeCopieDef$ = "_Copie" ' Chemin du fichier source à sauvegarder ' s'il n'y a pas d'argument dans la ligne de commande Public Const sCheminSrcDef$ = "" ' Sous-dossier où placer les sauvegardes (relatif à l'emplacement ' de la source à sauvegarder) ou sinon chemin complet du dossier ' des sauvegardes. On peut aussi laisser vide Public Const sDossierSauvegardesDef$ = "\Sauvegardes" ' Chemin du fichier de conservation des traces d'exécution, le cas échéant ' (laisser vide pour ne pas activer le traçage). Utile lorsque AccessBackup ' est lancé depuis une tâche planifiée sans ouverture de session Public Const sCheminTraceDef$ = "" ' Nombre de versions distinctes récentes conservées ' (par exemple les 5 dernières versions) Public Const iNbVersionsRoulementDef% = 5 ' Format pour conserver au moins 9 versions précédentes 'Public Const sFormatVersionsRoulementDef$ = "0" Public Const sFormatVersionsRoulementDef$ = "00" ' 99 versions précédentes ' Suffixe pour les fichiers d'archive définitive Public Const sSuffixeArchiveDef$ = "Arch" ' Période d'archivage : Nombre de jours d'intervalle ' pour faire une nouvelle archive définitive Public Const iPeriodeArchJoursDef% = 7 ' Format pour conserver au moins 999 versions d'archives ' (en cas de dépassement, le tri des fichiers ne sera pas parfait) Public Const sFormatVersionsArchDef$ = "000" End Module frmAccessBackup.vb ' Fichier frmAccessBackup.vb ' -------------------------- Public Class frmAccessBackup Private m_sCheminTrace$, m_sCheminSrc$ Private m_sDossierSauvegardes$, m_sDossierSauvegardesIncert$ Private m_sFormatVersionsRoulement$, m_sFormatVersionsArch$ Private m_iPeriodeArchJours%, m_iNbVersionsRoulement% 'Private m_bQuitter As Boolean Private m_sSuffixeArchive$, m_sSuffixeCopie$ Private m_sSuffixeBdOuverte$, m_sSuffixeBdOuverteCompactee$ Private m_sSuffixeBdFermee$ Private m_sMotDePasse$ = "" ' 01/11/2009 Private m_bCompactRepair As Boolean ' 16/03/2013 #Region " Propriétés de la classe " Public WriteOnly Property sCheminSrc$() 'Get ' sCheminSrc = m_sCheminSrc 'End Get Set(ByVal sCheminSrc0$) m_sCheminSrc = sCheminSrc0 End Set End Property Public WriteOnly Property sCheminTrace$() Set(ByVal sCheminTrace0$) m_sCheminTrace = sCheminTrace0 End Set End Property Public WriteOnly Property sDossierSauvegardes$() Set(ByVal sDossierSauvegardes0$) m_sDossierSauvegardes = sDossierSauvegardes0 End Set End Property Public WriteOnly Property sDossierSauvegardesIncert$() Set(ByVal sDossierSauvegardesIncert0$) m_sDossierSauvegardesIncert = sDossierSauvegardesIncert0 End Set End Property Public WriteOnly Property sSuffixeArchive$() Set(ByVal sSuffixeArchive0$) m_sSuffixeArchive = sSuffixeArchive0 End Set End Property Public WriteOnly Property sSuffixeCopie$() Set(ByVal sSuffixeCopie0$) m_sSuffixeCopie = sSuffixeCopie0 End Set End Property Public WriteOnly Property sSuffixeBdOuverte$() Set(ByVal sSuffixeBdOuverte0$) m_sSuffixeBdOuverte = sSuffixeBdOuverte0 End Set End Property Public WriteOnly Property sSuffixeBdOuverteCompactee$() Set(ByVal sSuffixeBdOuverteCompactee0$) m_sSuffixeBdOuverteCompactee = sSuffixeBdOuverteCompactee0 End Set End Property Public WriteOnly Property sSuffixeBdFermee$() Set(ByVal sSuffixeBdFermee0$) m_sSuffixeBdFermee = sSuffixeBdFermee0 End Set End Property Public WriteOnly Property sFormatVersionsRoulement$() Set(ByVal sFormatVersionsRoulement0$) m_sFormatVersionsRoulement = sFormatVersionsRoulement0 End Set End Property Public WriteOnly Property sFormatVersionsArch$() Set(ByVal sFormatVersionsArch0$) m_sFormatVersionsArch = sFormatVersionsArch0 End Set End Property Public WriteOnly Property iPeriodeArchJours%() Set(ByVal iPeriodeArchJours0%) m_iPeriodeArchJours = iPeriodeArchJours0 End Set End Property Public WriteOnly Property iNbVersionsRoulement%() Set(ByVal iNbVersionsRoulement0%) m_iNbVersionsRoulement = iNbVersionsRoulement0 End Set End Property Public WriteOnly Property sMotDePasse$() ' 01/11/2009 Set(ByVal sMotDePasse0$) m_sMotDePasse = sMotDePasse0 End Set End Property Public WriteOnly Property bCompactRepair() As Boolean ' 16/03/2013 Set(ByVal bCompactRepair0 As Boolean) m_bCompactRepair = bCompactRepair0 End Set End Property #End Region Private Sub frmAccessBackup_Load(ByVal sender As Object, ByVal e As EventArgs) _ Handles MyBase.Load ' 16/03/2013 Dim sVersionAppli$ = My.Application.Info.Version.Major & _ "." & My.Application.Info.Version.Minor & _ My.Application.Info.Version.Build Dim sTxt$ = sTitreMsg & " - Version " & sVersionAppli & " (" & sDateVersionAppli & ")" If bDebug Then sTxt &= " - Debug" Me.Text = sTxt ' Attention, lorsqu'AccessBackUp est lancé depuis le gestionnaire ' de tâches de Windows, il n'a pas le focus, ne pas utiliser ' frmActivated, mais bien frmLoad ' Attendre une demi-seconde avant de lancer le backup ' pour laisser le temps d'afficher le frm Me.timerDebut.Interval = 500 Me.timerDebut.Start() End Sub Private Sub timerDebut_Tick(ByVal sender As Object, ByVal e As EventArgs) _ Handles timerDebut.Tick Me.timerDebut.Stop() Backup(m_sCheminSrc) If Not bBoucleInfinie Then Exit Sub ' Tester le backup toutes les 10 secondes Me.timerDebut.Interval = 10000 ' en millisec., soit 10 sec. Me.timerDebut.Start() End Sub Private Sub timerFin_Tick(ByVal sender As Object, ByVal e As EventArgs) _ Handles timerFin.Tick 'If m_bQuitter Then Me.Close() : Exit Sub End Sub Private Sub Backup(ByVal sCheminSrc$) ' Gestion des sauvegardes Static bEnCours As Boolean ' Eviter la réentrance dans la fonction (en cas de debug avec le timer) If bEnCours Then Exit Sub bEnCours = True Dim sMsgErr$ = "" Dim sMsgResultat$ = "" Dim bSucces As Boolean = False Sablier() Application.DoEvents() If sCheminSrc = "" Then sMsgResultat = "Rien à faire !" AfficherMsg(sMsgResultat) bSucces = True GoTo Fin End If If Not bFichierExiste(sCheminSrc, sMsgErr) Then GoTo Fin Dim sCheminCourant$ = IO.Path.GetDirectoryName(sCheminSrc) Dim sCheminDossierCopie$ = _ sDeduireChemin(m_sDossierSauvegardes, sCheminCourant) Dim sCheminDossierCopieIncert$ = _ sDeduireChemin(m_sDossierSauvegardesIncert, sCheminCourant) Dim sNomFichier$ = IO.Path.GetFileNameWithoutExtension(sCheminSrc) Dim sExt$ = IO.Path.GetExtension(sCheminSrc) ' Extension du fichier à archiver ' Traitement des bases Access Dim sTypeCopie$ = m_sSuffixeCopie Dim bBaseAccess As Boolean = False If sExt.ToLower = ".mdb" Or sExt.ToLower = ".mde" Then bBaseAccess = True Dim bBaseAccessDejaCompactee As Boolean = False Dim bBaseAccessFermee As Boolean = False Dim bBaseOuverteExclusivement As Boolean = False Dim bBaseOuverteExclusivLectureSeule As Boolean = False Dim iNbU% = 0 If bBaseAccess Then ' Pour une réparation, il ne faut pas vérifier les utilisateurs connectés ' car iNbUtilisateurs renvoie bBaseOuverteExclusivement avec l'erreur -2147467259 If m_bCompactRepair Then ' 16/03/2013 AfficherMsg("Compactage/réparation de la base en cours... :" & vbCrLf & sCheminSrc) If Not bCompacterMdb(sCheminSrc, sMsgErr, , , m_sMotDePasse) Then GoTo Fin sMsgResultat = "Compactage/réparation de la base effectué avec succès : " & sCheminSrc AfficherMsg("Compactage/réparation de la base terminé :" & vbCrLf & sCheminSrc) bSucces = True : GoTo Fin End If Dim sInfoUtilisateurs$ = "" Dim bBaseFiable As Boolean ' Nombre d'utilisateurs en cours de la base Access iNbU = iNbUtilisateurs(sCheminSrc, sMsgErr, , sInfoUtilisateurs, _ bBaseOuverteExclusivement, bBaseOuverteExclusivLectureSeule, _ bBaseFiable, , m_sMotDePasse) 'Dim sMsg$ = "Base MDB : " & vbCrLf & sCheminSrc & vbCrLf & _ ' sInfoUtilisateurs & vbCrLf & _ ' "Base fiable : " & CStr(IIf(bBaseFiable, "Oui", "Non")) 'MsgBox(sMsg, vbInformation, sTitreMsg) ' Si la base est ouverte en mode exclusif, on ne peut pas ' faire de sauvegarde maintenant If bBaseOuverteExclusivement Then sMsgResultat = "Base ouverte exclusivement : " & sCheminSrc AfficherMsg("Base ouverte exclusivement :" & vbCrLf & sCheminSrc) ' Succès dans le sens que la procédure se déroule sans erreur bSucces = True GoTo Fin End If ' La copie directe d'une base Access n'est considérée comme fiable que quand ' il n'y a personne de connecté dessus sTypeCopie = m_sSuffixeBdOuverte If iNbU = -1 Then ' 01/11/2009 sMsgResultat = "Erreur" GoTo Fin ElseIf iNbU = 0 Then sTypeCopie = m_sSuffixeBdFermee bBaseAccessFermee = True Else sCheminDossierCopie = sCheminDossierCopieIncert End If ' Si la base est dans un état intermédiaire (en cours d'écriture ?) ' ne pas faire de sauvegarde maintenant If Not bBaseFiable Then sMsgResultat = "Base suspecte : " & sCheminSrc AfficherMsg("Base suspecte :" & vbCrLf & sCheminSrc) ' Succès dans le sens que la procédure se déroule sans erreur bSucces = True GoTo Fin End If End If Dim sCheminCopie$ = sCheminDossierCopie & "\" & sNomFichier & sTypeCopie & sExt ' Si la copie du fichier existe, vérifier les dernières dates d'écriture AfficherMsg("Vérification des dernières dates d'écriture :" & vbCrLf & sCheminSrc) Dim dDateSrc As Date = IO.File.GetLastWriteTime(sCheminSrc) If bFichierExiste(sCheminCopie) Then Dim dDateCopie As Date = IO.File.GetLastWriteTime(sCheminCopie) If dDateSrc <= dDateCopie Then sMsgResultat = "A jour (" & dDateSrc & ") : " & sCheminSrc AfficherMsg("Pas de mise à jour à faire du fichier :" & vbCrLf & _ sCheminSrc & vbCrLf & "(date de la dernière écriture : " & dDateSrc & ")") If Not bIgnorerDateMAJ Then bSucces = True : GoTo Fin End If End If ' Compacter si c'est une base Access fermée, seulement après la vérification des dates ' car le compactage change logiquement la date d'écriture If bBaseAccessFermee And Not bBaseOuverteExclusivLectureSeule Then AfficherMsg("Compactage de la base en cours... :" & vbCrLf & sCheminSrc) If Not bCompacterMdb(sCheminSrc, sMsgErr, , , m_sMotDePasse) Then GoTo Fin 'AfficherMsg("Compactage de la base terminé :" & vbCrLf & sCheminSrc) bBaseAccessDejaCompactee = True End If ' Copier le nouveau fichier à la place de l'ancien : procéder en 2 étapes ' pour éviter de supprimer la dernière copie valable en cas de problème If Not bVerifierCreerDossier(sCheminDossierCopie, sMsgErr) Then GoTo Fin AfficherMsg("Sauvegarde du fichier en cours... :" & vbCrLf & sCheminSrc) Dim sCheminTmp$ = sCheminDossierCopie & "\" & sNomFichier & sSuffixeCopieTmp & sExt Dim sSrc$ = sCheminSrc Dim sDest$ = sCheminTmp If Not bSupprimerFichier(sDest, sMsgErr) Then GoTo fin If Not bCopierFichier(sSrc, sDest, sMsgErr) Then GoTo fin ' Remplacer la copie tmp par la copie finale sSrc = sCheminTmp sDest = sCheminCopie If Not bRenommerFichier(sSrc, sDest, sMsgErr) Then GoTo fin 'AfficherMsg("Sauvegarde du fichier terminé :" & vbCrLf & sCheminSrc) sMsgResultat = "Copié (" & dDateSrc & ") : " & sCheminSrc If bBaseAccess And Not bBaseAccessDejaCompactee And _ Not bBaseOuverteExclusivLectureSeule Then ' Compacter la copie de la base ouverte, en conservant la base d'origine ' non compactée pour pouvoir contrôler les dates Dim sCheminCopieOrig$ = sCheminCopie sTypeCopie = m_sSuffixeBdOuverteCompactee 'If bBaseOuverteExclusivLectureSeule Then 'sTypeCopie = m_sSuffixeBdFermee ' il faudrait aussi renommer la copie fiable en copie tmp : pas grave 'End If sCheminCopie = sCheminDossierCopie & "\" & sNomFichier & sTypeCopie & sExt AfficherMsg("Compactage de la base en cours... :" & vbCrLf & sCheminCopieOrig) If Not bCompacterMdb(sCheminCopieOrig, sMsgErr, sCheminCopie, , _ m_sMotDePasse) Then GoTo Fin 'AfficherMsg("Compactage de la base terminé :" & vbCrLf & sCheminCopieOrig) End If ' Compresser la copie (compactée si c'est une base Access) ' en utilisant un numéro temporaire ~00.zip qui sera renommé en ~.zip à la fin AfficherMsg("Compression du fichier en cours... :" & vbCrLf & sCheminCopie) Dim sCheminZipTmp$ = sCheminDossierCopie & "\" & sNomFichier & sTypeCopie & "00.zip" If Not bZipper(sCheminZipTmp, sCheminCopie, sMsgErr) Then GoTo Fin 'AfficherMsg("Compression du fichier terminé :" & vbCrLf & sCheminCopie) ' Faire une copie de roulement du fichier source (n dernières versions) Dim sCheminZipFin$ = "" If Not bRoulement(sNomFichier, sTypeCopie, sCheminZipTmp, sCheminZipFin, sMsgErr) Then GoTo Fin ' Faire un archivage définitif d'un fichier source Dim sCheminArch$ = "" If Not bArchiver(sNomFichier, sTypeCopie & m_sSuffixeArchive, _ sCheminZipFin, sCheminArch, sMsgErr) Then GoTo Fin bSucces = True Fin: If Not bSucces Then AfficherMsg(sMsgErr) If Me.m_sCheminTrace <> "" Then Dim sMsg$ = DateTime.Now.ToShortDateString() & _ " - " & DateTime.Now.ToLongTimeString() sMsg &= " : " & sMsgResultat If bBaseAccess Then If bBaseAccessFermee Then sMsg &= " - Base fermée" ElseIf bBaseOuverteExclusivement Then sMsg &= " - Base ouverte" ElseIf iNbU > 0 Then ' 01/11/2009 sMsg &= " - Base ouverte (" & iNbU & " ut.)" End If End If If sMsgErr <> "" Then sMsg &= vbCrLf & sMsgErr TracerExecution(sMsg) End If bEnCours = False Sablier(bDesactiver:=True) ' Recommencer indéfiniment If bBoucleInfinie Then Exit Sub 'm_bQuitter = True ' Laisser le temps de lire le statut de sauvergarde avant de quitter Me.timerFin.Interval = iDelaiLectureMsgMilliSec Me.timerFin.Start() End Sub Private Sub TracerExecution(ByVal sMsg$) Try Dim sCheminTrace$ = sDeduireChemin(m_sCheminTrace, Application.StartupPath) Dim sDossierTrace$ = IO.Path.GetDirectoryName(sCheminTrace) Dim sMsgErr$ = "" If Not bVerifierCreerDossier(sDossierTrace, sMsgErr) Then AfficherMsg("Erreur lors de l'écriture de la trace d'exécution : " & vbCrLf & _ "Chemin : " & sCheminTrace & vbCrLf & sMsgErr) Exit Sub End If Dim fs As IO.FileStream, sw As IO.StreamWriter fs = New IO.FileStream(sCheminTrace, IO.FileMode.Append, IO.FileAccess.Write) sw = New IO.StreamWriter(fs) sw.WriteLine(sMsg) sw.Close() Catch ex As Exception Dim sMsg0$ = "Erreur lors de l'écriture de la trace d'exécution : " & vbCrLf & _ "Chemin : " & m_sCheminTrace Dim sMsgErr$ = sMsg0 & vbCrLf & ex.Message AfficherMsg(sMsgErr) If bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bVerifierCreerDossier", sMsg0) End Try End Sub Private Sub AfficherMsg(ByVal sInfo$) Me.lblInfo.Text = sInfo Application.DoEvents() End Sub Public Sub Sablier(Optional ByVal bDesactiver As Boolean = False) If bDesactiver Then 'Cursor.Current = Cursors.Default Me.Cursor = Cursors.Default Else 'Cursor.Current = Cursors.WaitCursor Me.Cursor = Cursors.WaitCursor End If End Sub Private Function bRoulement(ByVal sNomFichierOrig$, ByVal sTypeCopie$, _ ByVal sCheminSrc$, ByRef sCheminDest$, ByRef sMsgErr$) As Boolean ' Faire une copie de roulement d'un fichier source pour conserver ' les n dernières versions d'archive temporaire ' et renvoyer le chemin du fichier Zip le plus récent : sCheminDest Dim i%, sSrc$, sDest$ AfficherMsg("Copie de roulement de la base attachée en cours... :" & vbCrLf & sCheminSrc) ' Chemin du dossier courant du fichier source Dim sCheminCourant$ = IO.Path.GetDirectoryName(sCheminSrc) Dim sExt$ = IO.Path.GetExtension(sCheminSrc) ' Extension du fichier à archiver ' Parcourir les versions à l'envers (en supprimant la dernière) For i = m_iNbVersionsRoulement - 1 To -1 Step -1 ' Remplacer l'archive n°i+1 par l'archive n°i sSrc = sCheminCourant & "\" & sNomFichierOrig & sTypeCopie & _ sFormater(i, m_sFormatVersionsRoulement) & sExt sDest = sCheminCourant & "\" & sNomFichierOrig & sTypeCopie & _ sFormater(i + 1, m_sFormatVersionsRoulement) & sExt If i = 0 Then ' Avant dernier fichier : remplacer le précédent fichier principal par l'archive n°1 sSrc = sCheminCourant & "\" & sNomFichierOrig & sTypeCopie & sExt ElseIf i = -1 Then ' Dernier fichier : remplacer le fichier temporaire source par ' le nouveau fichier principal sSrc = sCheminSrc sDest = sCheminCourant & "\" & sNomFichierOrig & sTypeCopie & sExt sCheminDest = sDest End If If bFichierExiste(sSrc) AndAlso Not bRenommerFichier(sSrc, sDest, sMsgErr) Then Exit Function Next i 'AfficherMsg("Copie de roulement de la base attachée terminé :" & vbCrLf & sCheminDest) bRoulement = True End Function Private Function bArchiver(ByVal sNomFichierOrig$, ByVal sTypeCopie$, ByVal sCheminSrc$, _ ByRef sCheminDest$, ByRef sMsgErr$) As Boolean ' Faire un archivage définitif d'un fichier source si le précédent archivage est ancien : ' dans ce cas, le numéro de version augmente de 1 et le fichier de destination est retourné ' Chemin du dossier courant du fichier à archiver Dim sCheminCourant$ = IO.Path.GetDirectoryName(sCheminSrc) Dim sExt$ = IO.Path.GetExtension(sCheminSrc) ' Extension du fichier à archiver ' Filtre de recherche des archives du fichier Dim sFiltre$ = sNomFichierOrig & sTypeCopie & "*" & sExt Dim sDernierBackup$ = "" ' Mémorisation du dernier fichier d'archive Dim di As New IO.DirectoryInfo(sCheminCourant) Dim fi As IO.FileInfo() = di.GetFiles(sFiltre) ' Liste des fichiers d'archives Dim iNbFichiers% = fi.GetLength(0) ' Méthode + sûre : rechercher le n° max. des fichiers, car il peut en manquer Dim i% Dim sRacine$ = sNomFichierOrig & sTypeCopie Dim iLenRacine% = sRacine.Length Dim iNumMaxFichier% = 1 For i = 0 To iNbFichiers - 1 Dim sFichier$ = IO.Path.GetFileNameWithoutExtension(fi(i).Name) Dim sNumFichier$ = sFichier.Substring(iLenRacine) Dim iNumFichier% = iConvertir(sNumFichier, 0) If iNumFichier > iNumMaxFichier Then iNumMaxFichier = iNumFichier Next i iNbFichiers = iNumMaxFichier Do ' Trouver le prochain numéro de fichier d'archive sCheminDest = sCheminCourant & "\" & sNomFichierOrig & sTypeCopie & _ sFormater(iNbFichiers, m_sFormatVersionsArch) & sExt If Not IO.File.Exists(sCheminDest) Then Exit Do sDernierBackup = sCheminDest iNbFichiers += 1 Loop If sDernierBackup <> "" Then ' Vérifier la date du dernier fichier d'archive Dim dDateSrc As Date = IO.File.GetLastWriteTime(sCheminSrc) Dim dDateBak As Date = IO.File.GetLastWriteTime(sDernierBackup) ' Arrondir au nombre de jour le plus proche en passant par les heures Dim iNbJours% = CInt(DateDiff(DateInterval.Hour, dDateBak, dDateSrc) / 24) If iNbJours < m_iPeriodeArchJours Then AfficherMsg("Archive assez récente :" & vbCrLf & _ sCheminSrc & vbCrLf & _ "(date actuelle : " & dDateSrc.ToShortDateString & _ ", date archive : " & dDateBak.ToShortDateString & _ " : nb. jours : " & iNbJours & " < " & _ m_iPeriodeArchJours & ")") bArchiver = True Exit Function End If End If AfficherMsg("Archivage du fichier en cours... :" & vbCrLf & sCheminSrc) If Not bCopierFichier(sCheminSrc, sCheminDest, sMsgErr) Then Exit Function AfficherMsg("Archivage du fichier terminé :" & vbCrLf & sCheminDest) bArchiver = True End Function End Class modUtil.vb ' Fichier modUtil.vb ' ------------------ Module modUtil Public Function asArgLigneCmd(ByVal sFichiers$) As String() ' Retourner les arguments de la ligne de commande Dim asArgs$() = Nothing 'MsgBox "Arguments : " & Command, vbInformation, sTitreMsg ' Parser les noms cours : facile 'asArgs = Split(Command, " ") ' Parser les noms longs (fonctionne quel que soit le nombre de fichiers) ' Chaque nom long de fichier est entre guillemets : "" ' une fois le nom traité, les guillemets sont enlevés ' S'il y a un non court parmi eux, il n'est pas entre guillemets Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim iNbArg%, sFichier$, sSepar$ Dim sCmd$, iLen%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong 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 += 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 += 1 End If If bFin Or iFin = iLen Then Exit Do iDeb = iFin + 1 If bNomLong Then iDeb = iFin + 2 Loop Const iCodeGuillemets% = 34 Dim iNumArg% For iNumArg = 0 To UBound(asArgs) asArgs(iNumArg) = Trim$(asArgs(iNumArg)) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide If Len(sArg) = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" End If Next iNumArg asArgLigneCmd = asArgs End Function Public Function iConvertir%(ByVal sVal$, ByVal iValDef%) ' Convertir en un entier une chaîne représentant un entier, sans provoquer ' d'erreur, mais plutôt en fixant une valeur par défaut dans ce cas Try iConvertir = CInt(sVal) Catch 'ex As Exception iConvertir = iValDef End Try End Function Public Function bAppliDejaOuverte(ByVal bMemeExe As Boolean) As Boolean ' Détecter si l'application est déja lancée : ' - depuis n'importe quelle copie de l'exécutable, ou bien seulement ' - depuis le même emplacement du fichier exécutable sur le disque dur Dim sExeProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.ModuleName Dim sNomProcessAct$ = IO.Path.GetFileNameWithoutExtension(sExeProcessAct) If Not bMemeExe Then ' Détecter si l'application est déja lancée depuis n'importe quel exe If Process.GetProcessesByName(sNomProcessAct).Length > 1 Then _ bAppliDejaOuverte = True Exit Function End If ' Détecter si l'application est déja lancée depuis le même exe Dim sCheminProcessAct$ = Diagnostics.Process.GetCurrentProcess.MainModule.FileName Dim aProcessAct As Diagnostics.Process() = Process.GetProcessesByName(sNomProcessAct) Dim processAct As Diagnostics.Process Dim iNbApplis% = 0 For Each processAct In aProcessAct Dim sCheminExe$ = processAct.MainModule.FileName If sCheminExe = sCheminProcessAct Then iNbApplis += 1 Next If iNbApplis > 1 Then bAppliDejaOuverte = True End Function Public Function sFormater$(ByVal iVal%, ByVal sFormat$) ' Formater un entier selon un format précisé (même syntaxe que VB6) sFormater = iVal.ToString(sFormat) End Function Public Function bCreerObjet(ByRef oObjetQcq As Object, ByVal sClasse$, _ ByRef sMsgErr$, Optional ByVal bPromptErr As Boolean = False) As Boolean ' Créer une instance d'une classe OLE COM ActiveX, et renvoyer sa référence Try oObjetQcq = CreateObject(sClasse) bCreerObjet = True Catch ex As Exception oObjetQcq = Nothing Dim sMsg$ = "bCreerObjet : L'objet de classe [" & sClasse & _ "] ne peut pas être créé" sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bCreerObjet", sMsg) End Try End Function Public Sub AfficherMsgErreur(ByRef Erreur As Microsoft.VisualBasic.ErrObject, _ Optional ByVal sTitreFct$ = "", _ Optional ByVal sInfo$ = "", Optional ByVal sDetailMsgErr$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If Erreur.Number > 0 Then sMsg &= vbCrLf & "Err n°" & Erreur.Number.ToString & " :" sMsg &= vbCrLf & Erreur.Description End If If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) End Sub Public Sub AfficherMsgErreur2(ByRef Ex As Exception, _ Optional ByVal sTitreFct$ = "", Optional ByVal sInfo$ = "", _ Optional ByVal sDetailMsgErr$ = "", _ Optional ByVal bCopierMsgPressePapier As Boolean = True, _ Optional ByRef sMsgErrFinal$ = "") If Not Cursor.Current.Equals(Cursors.Default) Then _ Cursor.Current = Cursors.Default Dim sMsg$ = "" If sTitreFct <> "" Then sMsg = "Fonction : " & sTitreFct If sInfo <> "" Then sMsg &= vbCrLf & sInfo If sDetailMsgErr <> "" Then sMsg &= vbCrLf & sDetailMsgErr If Ex.Message <> "" Then sMsg &= vbCrLf & Ex.Message.Trim If Not IsNothing(Ex.InnerException) Then _ sMsg &= vbCrLf & Ex.InnerException.Message End If If bCopierMsgPressePapier Then CopierPressePapier(sMsg) sMsgErrFinal = sMsg MsgBox(sMsg, MsgBoxStyle.Critical) End Sub Public Sub CopierPressePapier(ByVal sInfo$) ' Copier des informations dans le presse-papier de Windows ' (elles resteront jusqu'à ce que l'application soit fermée) Try Dim dataObj As New DataObject dataObj.SetData(DataFormats.Text, sInfo) Clipboard.SetDataObject(dataObj) Catch ex As Exception ' Le presse-papier peut être indisponible AfficherMsgErreur2(ex, "CopierPressePapier", _ bCopierMsgPressePapier:=False) End Try End Sub End Module modUtilDAO.vb ' Fichier modUtilDAO.vb ' --------------------- Module modUtilDAO Public Function iNbUtilisateurs%(ByVal sCheminMbd$, _ ByRef sMsgErr$, _ Optional ByRef sListeUtilisateurs$ = "", _ Optional ByRef sInfoUtilisateurs$ = "", _ Optional ByRef bBaseOuverteExclusivement As Boolean = False, _ Optional ByRef bBaseOuverteExclusivLectureSeule As Boolean = False, _ Optional ByRef bBaseFiable As Boolean = True, _ Optional ByVal bPromptErr As Boolean = False, _ Optional ByVal sMotDePasse$ = "") ' Trouver le nombre d'utilisateur en cours d'une base de données ' Avantage : pas besoin de DLL (la méthode avec la dll MSLDBUSR.DLL ' ne marche pas en DotNet) ' Inconvénients : ' - cette fonction ouvre une connexion ; ' - en cours de développement sur une base Access, celle-ci peut être ' verrouillée : impossible alors de lire la table (pas grave) bBaseFiable = True ' Liaison précoce ou anticipée : à la compilation Dim oConnADODB As ADODB.Connection Dim oRq As ADODB.Recordset If bTrapErr Then On Error GoTo Erreur Else On Error GoTo 0 oConnADODB = New ADODB.Connection oRq = New ADODB.Recordset oConnADODB.Provider = "Microsoft.Jet.OLEDB.4.0" 'http://msdn.microsoft.com/en-us/library/ms676505(VS.85).aspx Open 'http://msdn.microsoft.com/en-us/library/ms675810(VS.85).aspx ConnectionString If sMotDePasse.Length > 0 Then ' 01/11/2009 ' How to open a secured Access database in ADO through OLE DB 'http://support.microsoft.com/kb/191754/en-us oConnADODB.Open("Data Source=" & sCheminMbd & _ ";Jet OLEDB:Database Password=" & sMotDePasse) Else oConnADODB.Open("Data Source=" & sCheminMbd) End If ' Test d'ouverture d'une autre connexion 'Dim oConn2 As New ADODB.Connection 'oConn2.Open "Provider=Microsoft.Jet.OLEDB.4.0;" _ ' & "Data Source=" & sCheminMbd ' The user roster is exposed as a provider-specific schema rowset ' in the Jet 4 OLE DB provider. You have to use a GUID to ' reference the schema, as provider-specific schemas are not ' listed in ADO's type library for schema rowsets 'Const adSchemaProviderSpecific& = -1 '(&HFFFFFFFF) Const JET_SCHEMA_USERROSTER$ = _ "{947bb102-5d43-11d1-bdbf-00c04fb92675}" oRq = oConnADODB.OpenSchema( _ ADODB.SchemaEnum.adSchemaProviderSpecific, , JET_SCHEMA_USERROSTER) ' Output the list of all users in the current database. 'Debug.Print(oRq.Fields(0).Name, "", oRq.Fields(1).Name, _ ' "", oRq.Fields(2).Name, oRq.Fields(3).Name) ' COMPUTER_NAME LOGIN_NAME CONNECTED SUSPECT_STATE ' X Admin Vrai Null ' NOTES: Fields as follows ' 0 - COMPUTER_NAME: Workstation ' 1 - LOGIN_NAME: Name used to Login to DB ' 2 - CONNECTED: True if Lock in LDB File ' 3 - SUSPECTED_STATE: True if user has left database in a suspect state (else Null) Const iColOrdi% = 0 Const iCol_bSusp% = 3 Dim iNumUtilisateur%, sOrdi$, sPremierUtilisateur$, sMemListeUtilisateurs$ Dim bBaseSuspecte As Boolean Dim bBaseFiable0 As Boolean Const iNbUtilisateursAffMax% = 5 sPremierUtilisateur = "" sMemListeUtilisateurs = "" ' Ne fonctionne pas en ADO : -1 ??? 'oRq.MoveLast() 'iNbUtilisateurs = oRq.RecordCount 'oRq.MoveFirst() While Not oRq.EOF bBaseSuspecte = CBool(oNz(oRq.Fields(iCol_bSusp).Value, False)) If bBaseSuspecte Then bBaseFiable = False sMemListeUtilisateurs = sListeUtilisateurs iNumUtilisateur = iNumUtilisateur + 1 If iNumUtilisateur > iNbUtilisateursAffMax Then sListeUtilisateurs = sListeUtilisateurs & "..." Else sOrdi = CStr(oNz(oRq.Fields(iColOrdi).Value, "?")) sOrdi = sOrdi.TrimEnd ' Suppression du dernier caractère sOrdi = sOrdi.Substring(0, sOrdi.Length - 1) If sPremierUtilisateur = "" Then sPremierUtilisateur = sOrdi If sListeUtilisateurs = "" Then sListeUtilisateurs = "Utilisateur n°" & _ iNumUtilisateur & " : " & sOrdi Else sListeUtilisateurs &= vbCrLf & "Utilisateur n°" & _ iNumUtilisateur & " : " & sOrdi End If End If oRq.MoveNext() End While If iNumUtilisateur = 0 Then ' Si on a réussi à ouvrir une connexion mais qu'elle n'est pas comptabilisée ' alors c'est que la base est ouverte en mode exclusif + lecture seule bBaseOuverteExclusivLectureSeule = True ' On considère qu'il n'y aucun utilisateur, car il ne peut y faire de modification ' et on peut faire une copie fiable de la base de données iNbUtilisateurs = 0 Else ' -1 pour la connexion qui sert dans cette fonction iNbUtilisateurs = iNumUtilisateur - 1 sListeUtilisateurs = sMemListeUtilisateurs End If Fin: If Not (oRq Is Nothing) AndAlso _ oRq.State = ADODB.ObjectStateEnum.adStateOpen Then oRq.Close() If Not (oConnADODB Is Nothing) AndAlso _ oConnADODB.State = ADODB.ObjectStateEnum.adStateOpen Then oConnADODB.Close() If iNbUtilisateurs = 1 Then sInfoUtilisateurs = "1 seul utilisateur en cours de la base : " & _ sPremierUtilisateur ElseIf iNbUtilisateurs > 0 Then sInfoUtilisateurs = iNbUtilisateurs & _ " utilisateurs en cours de la base :" & vbCrLf & _ sListeUtilisateurs ElseIf iNbUtilisateurs = 0 Then sInfoUtilisateurs = "Base fermée." Else sInfoUtilisateurs = _ "Utilisateurs en cours de la base : ? (réessayer plus tard)" End If Exit Function Erreur: iNbUtilisateurs = -1 Dim sMsg$ = _ "Impossible d'obtenir la liste des utilisateurs connectés à la base :" & _ sCheminMbd ' Base ouverte en mode exclusif If Err.Number = -2147467259 Then bBaseOuverteExclusivement = True : Resume Fin sMsgErr = sMsg & vbCrLf & Err.Description If bPromptErr Or bPromptErrGlob Then AfficherMsgErreur(Err, "iNbUtilisateurs", sMsg) AfficherErreursADO(oConnADODB) End If Resume Fin End Function Private Sub AfficherErreursADO(ByRef oConnexion As ADODB.Connection) If oConnexion Is Nothing Then Exit Sub 'If oConnexion.State <> ADODB.ObjectStateEnum.adStateOpen Then Exit Sub Dim sMsg$ = "" Dim errDB As ADODB.Error For Each errDB In oConnexion.Errors sMsg &= "Erreur ADO : " & errDB.Description & vbCrLf sMsg &= "Numéro : " & errDB.Number & " (" & _ Hex(errDB.Number) & "), Erreur Jet : " & errDB.SQLState & vbCrLf MsgBox(sMsg, MsgBoxStyle.Critical, sTitreMsg) Next errDB End Sub Public Function oNz(ByVal oVal As Object, Optional ByVal oDef As Object = 0) As Object ' Implementation de la fonction Nz d'Access en VB7 : ' Non Zero : renvoyer 0 (ou une autre valeur par défaut) ' si la valeur du champ de bd est null ' ou sinon renvoyer simplement une copie de la valeur : ByVal ' Mieux vaut passer les objets en valeur : copie, au lieu de ref : le pointeur ' sur la valeur, par ex. pour lire une valeur d'un enreg : si on garde ByRef, ' on obtient une err comme quoi l'objet ne peut être mis à jour : "Informations ' supplémentaires : Le jeu d'enregistrements suivant ne prend pas en charge la ' mise à jour. Il s'agit peut-être d'une limitation du fournisseur ou du type ' de verrou sélectionné." If IsDBNull(oVal) Then oNz = oDef : Exit Function If oVal Is System.DBNull.Value Then oNz = oDef : Exit Function If oVal Is Nothing Then oNz = oDef : Exit Function ' Pour les chaînes vides oNz = oVal End Function End Module modUtilDAO2.vb ' Fichier modUtilDAO2.vb ' ---------------------- Option Strict Off ' Pour DAO.DBEngine.CompactDatabase Module modUtilDAO2 Public Function bCompacterMdb(ByVal sCheminBaseSrc$, ByRef sMsgErr$, _ Optional ByVal sCheminBaseDest$ = "", _ Optional ByVal bPromptErr As Boolean = False, _ Optional ByVal sMotDePasse$ = "") As Boolean Dim sCheminCourant$ = IO.Path.GetDirectoryName(sCheminBaseSrc) Dim sNomFichier$ = IO.Path.GetFileNameWithoutExtension(sCheminBaseSrc) ' Extension du fichier à archiver Dim sExt$ = IO.Path.GetExtension(sCheminBaseSrc) Dim bRetablirNom As Boolean = False If sCheminBaseDest = "" Then ' Si on ne précise pas la base de destination, il faudra rétablir le ' nom d'origine après le compactage, à partir d'un nom temporaire sCheminBaseDest = sCheminCourant & "\" & sNomFichier & sSuffixeCompactTmp & sExt bRetablirNom = True End If If Not bSupprimerFichier(sCheminBaseDest, sMsgErr) Then Exit Function Dim oDBE As Object = Nothing If Not bCreerObjet(oDBE, "DAO.DBEngine.36", sMsgErr) Then Exit Function Try 'http://msdn.microsoft.com/en-us/library/bb220986.aspx If sMotDePasse.Length > 0 Then ' 01/11/2009 ' Si la bd n'a pas de mot de passe, cela fonctionnera aussi, ' mais attention car la base compactée elle sera protégée ! 'http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_20268832.html oDBE.CompactDatabase(sCheminBaseSrc, sCheminBaseDest, _ ";pwd=" & sMotDePasse, , ";pwd=" & sMotDePasse) Else oDBE.CompactDatabase(sCheminBaseSrc, sCheminBaseDest) End If Catch ex As Exception Dim sMsg$ = "Echec du compactage de la base :" & vbCrLf & _ sCheminBaseSrc & vbCrLf sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bCompacterMdb", sMsg) Exit Function Finally oDBE = Nothing End Try If bRetablirNom Then ' Rétablir le nom d'origine du fichier If Not bRenommerFichier(sCheminBaseDest, sCheminBaseSrc, sMsgErr) Then sMsgErr = "Echec du compactage de la base :" & vbCrLf & _ sCheminBaseSrc & vbCrLf & sMsgErr ' En cas d'échec, supprimer la version compactée Dim sMsgErr0$ = "" If Not bSupprimerFichier(sCheminBaseDest, sMsgErr0) Then Exit Function Exit Function End If End If bCompacterMdb = True End Function End Module modUtilFichier.vb ' Fichier modUtilFichier.vb ' ------------------------- Module modUtilFichier Public Const sCauseErrPoss$ = _ "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Function bFichierExiste(ByVal sCheminFichier$, _ Optional ByRef sMsg$ = "", _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourne True si un fichier correspondant est trouvé ' Ne fonctionne pas avec un filtre, par ex. du type C:\*.txt bFichierExiste = IO.File.Exists(sCheminFichier) If bFichierExiste Then Exit Function sMsg = "Impossible de trouver le fichier :" & vbCrLf & sCheminFichier If bPrompt Then MsgBox(sMsg, MsgBoxStyle.Critical, _ sTitreMsg & " - Fichier introuvable") End Function Public Function bSupprimerFichier(ByVal sCheminFichier$, _ ByRef sMsgErr$, Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste(sCheminFichier) Then _ bSupprimerFichier = True : Exit Function ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) bSupprimerFichier = True Catch ex As Exception Dim sMsg$ = "Impossible de supprimer le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bSupprimerFichier", sMsg) End Try End Function Public Function bCopierFichier(ByVal sSrc$, ByVal sDest$, _ ByRef sMsgErr$, Optional ByVal bPromptErr As Boolean = False) As Boolean Try IO.File.Copy(sSrc, sDest) bCopierFichier = True Catch ex As Exception Dim sMsg$ = "Impossible de copier le fichier source :" & vbCrLf & _ sSrc & vbCrLf & "vers le fichier de destination :" & vbCrLf & _ sDest & vbCrLf & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bCopierFichier", sMsg) End Try End Function Public Function bRenommerFichier(ByVal sSrc$, ByVal sDest$, _ ByRef sMsgErr$, Optional ByVal bPromptErr As Boolean = False) As Boolean If Not bFichierExiste(sSrc, sMsgErr) Then Exit Function If Not bSupprimerFichier(sDest, sMsgErr) Then Exit Function Try IO.File.Move(sSrc, sDest) bRenommerFichier = True Catch ex As Exception Dim sMsg$ = "Impossible de renommer le fichier source :" & vbCrLf & _ sSrc & vbCrLf & "vers le fichier de destination :" & vbCrLf & _ sDest & sCauseErrPoss sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bRenommerFichier", sMsg) End Try End Function Public Function bDossierExiste(ByVal sDossier$, _ Optional ByRef sMsg$ = "", _ Optional ByVal bPrompt As Boolean = False) As Boolean ' Retourner True si un dossier correspondant au dossier sDossier est trouvé Dim di As New IO.DirectoryInfo(sDossier) bDossierExiste = di.Exists() If bDossierExiste Then Exit Function sMsg = "Impossible de trouver le dossier :" & vbCrLf & sDossier If bPrompt Then MsgBox(sMsg, MsgBoxStyle.Critical, _ sTitreMsg & " - Dossier introuvable") End Function Public Function bVerifierCreerDossier(ByRef sCheminDossier$, _ ByRef sMsgErr$, Optional ByVal bPromptErr As Boolean = False) As Boolean ' Vérifier et créer le dossier If sCheminDossier = "" Then bVerifierCreerDossier = True : Exit Function Dim sMsgErr0$ = "Impossible de créer le dossier :" & vbCrLf & sCheminDossier Dim di As IO.DirectoryInfo Try di = New IO.DirectoryInfo(sCheminDossier) If Not di.Exists Then di.Create() di = New IO.DirectoryInfo(sCheminDossier) End If If Not di.Exists Then sMsgErr = sMsgErr0 If bPromptErr Or bPromptErrGlob Then _ MsgBox(sMsgErr, MsgBoxStyle.Critical, _ sTitreMsg & " - bVerifierCreerDossier") Exit Function End If bVerifierCreerDossier = True Catch ex As Exception sMsgErr = sMsgErr0 & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bVerifierCreerDossier", sMsgErr0) End Try End Function Public Function sDossierRacine$(ByVal sCheminOuDossier$) ' Extraire le dossier racine d'un chemin sDossierRacine = IO.Path.GetPathRoot(sCheminOuDossier) ' Ne pas considerer \ comme un dossier racine, ' mais plutot le chemin comme un sous-dossier relatif If sDossierRacine = "\" Then sDossierRacine = "" End Function Public Function sDeduireChemin$(ByVal sDossier$, ByVal sCheminCourant$) ' Déduire le dossier en fonction du dossier ou chemin d'origine et ' du chemin courant (chemin de référence) Dim sLecteur$ = sDossierRacine(sDossier) If sLecteur = "" Then If sDossier.Chars(0) = "\" Then sDeduireChemin = sCheminCourant & sDossier Else sDeduireChemin = sCheminCourant & "\" & sDossier End If Else sDeduireChemin = sDossier End If End Function End Module modZip.vb ' Fichier modZip.vb ' ----------------- Imports System.IO Imports ICSharpCode.SharpZipLib.Zip Module modZip Public Function bZipper(ByVal sCheminZip$, ByVal sCheminFichier$, _ ByRef sMsgErr$, Optional ByVal bPromptErr As Boolean = False) As Boolean ' Compresser le fichier sCheminFichier dans le fichier sCheminZip Const iTailleBuffer% = 4096 Dim aOctets(iTailleBuffer) As Byte Try Dim zosFluxZip As New ZipOutputStream(File.Create(sCheminZip)) zosFluxZip.SetLevel(5) ' Niveau de compression max. ' Possibilité de mettre un commentaire dans le fichier zip 'zosFluxZip.SetComment("AccessBackup") If File.Exists(sCheminFichier) Then ' Ouverture en lecture du fichier à zipper Dim fsFlux As FileStream fsFlux = File.OpenRead(sCheminFichier) ' Enregistrement dans le zip de la référence du fichier d'entrée Dim zeFichier As New ZipEntry(Path.GetFileName(sCheminFichier)) zosFluxZip.PutNextEntry(zeFichier) ' Lecture et zip du fichier par blocs de 4096 bytes Dim iNbOctetsLus% = fsFlux.Read(aOctets, 0, iTailleBuffer) While (iNbOctetsLus > 0) zosFluxZip.Write(aOctets, 0, iNbOctetsLus) iNbOctetsLus = fsFlux.Read(aOctets, 0, iTailleBuffer) End While fsFlux.Flush() fsFlux.Close() End If zosFluxZip.Close() bZipper = True Catch ex As Exception Dim sMsg$ = "Impossible de compresser le fichier :" & vbCrLf & _ sCheminFichier & vbCrLf & _ "dans le fichier Zip :" & vbCrLf & sCheminZip sMsgErr = sMsg & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bZipper", sMsg) End Try End Function End Module