AccessBackup v1.0.6.*Table des procédures 1 - AssemblyInfo.vb 2 - frmAccessBackup.vb 2.1 - Private Function bArchiver 2.2 - Private Function bRoulement 2.3 - Private Sub AfficherMsg 2.4 - Private Sub Backup 2.5 - Private Sub frmAccessBackup_Load 2.6 - Private Sub timerDebut_Tick 2.7 - Private Sub timerFin_Tick 2.8 - Private Sub TracerExecution 2.9 - Public Sub Sablier 2.10 - Public WriteOnly Property bCompactRepair 2.11 - Public WriteOnly Property iNbVersionsRoulement% 2.12 - Public WriteOnly Property iPeriodeArchJours% 2.13 - Public WriteOnly Property sCheminSrc$ 2.14 - Public WriteOnly Property sCheminTrace$ 2.15 - Public WriteOnly Property sDossierSauvegardes$ 2.16 - Public WriteOnly Property sDossierSauvegardesIncert$ 2.17 - Public WriteOnly Property sFormatVersionsArch$ 2.18 - Public WriteOnly Property sFormatVersionsRoulement$ 2.19 - Public WriteOnly Property sMotDePasse$ 2.20 - Public WriteOnly Property sSuffixeArchive$ 2.21 - Public WriteOnly Property sSuffixeBdFermee$ 2.22 - Public WriteOnly Property sSuffixeBdOuverte$ 2.23 - Public WriteOnly Property sSuffixeBdOuverteCompactee$ 2.24 - Public WriteOnly Property sSuffixeCopie$ 3 - modConst.vb 4 - modDepart.vb 4.1 - Public Sub DefinirTitreApplication 4.2 - Public Sub Main 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 - modUtilFichierAvecGestionErrParMsg.vb 8.1 - Public Function bCopierFichier2 8.2 - Public Function bFichierExiste2 8.3 - Public Function bRenommerFichier2 8.4 - Public Function bSupprimerFichier2 8.5 - Public Function bVerifierCreerDossier2 8.6 - Public Function sDeduireChemin$ 8.7 - Public Function sDossierRacine$ 9 - modZip.vb 9.1 - Public Function bZipper AssemblyInfo.vb ' Fichier AssemblyInfo.vb ' ----------------------- 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("")> <Assembly: AssemblyProduct("AccessBackup")> <Assembly: AssemblyCopyright("Copyright © 2024")> <Assembly: AssemblyTrademark("AccessBackup")> <Assembly: CLSCompliant(True)> <Assembly: AssemblyVersion("1.0.6.*")> frmAccessBackup.vb ' Fichier frmAccessBackup.vb ' -------------------------- ' 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 ' ... ' ------------------------------------ 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_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(sCheminSrc0$) m_sCheminSrc = sCheminSrc0 End Set End Property Public WriteOnly Property sCheminTrace$() Set(sCheminTrace0$) m_sCheminTrace = sCheminTrace0 End Set End Property Public WriteOnly Property sDossierSauvegardes$() Set(sDossierSauvegardes0$) m_sDossierSauvegardes = sDossierSauvegardes0 End Set End Property Public WriteOnly Property sDossierSauvegardesIncert$() Set(sDossierSauvegardesIncert0$) m_sDossierSauvegardesIncert = sDossierSauvegardesIncert0 End Set End Property Public WriteOnly Property sSuffixeArchive$() Set(sSuffixeArchive0$) m_sSuffixeArchive = sSuffixeArchive0 End Set End Property Public WriteOnly Property sSuffixeCopie$() Set(sSuffixeCopie0$) m_sSuffixeCopie = sSuffixeCopie0 End Set End Property Public WriteOnly Property sSuffixeBdOuverte$() Set(sSuffixeBdOuverte0$) m_sSuffixeBdOuverte = sSuffixeBdOuverte0 End Set End Property Public WriteOnly Property sSuffixeBdOuverteCompactee$() Set(sSuffixeBdOuverteCompactee0$) m_sSuffixeBdOuverteCompactee = sSuffixeBdOuverteCompactee0 End Set End Property Public WriteOnly Property sSuffixeBdFermee$() Set(sSuffixeBdFermee0$) m_sSuffixeBdFermee = sSuffixeBdFermee0 End Set End Property Public WriteOnly Property sFormatVersionsRoulement$() Set(sFormatVersionsRoulement0$) m_sFormatVersionsRoulement = sFormatVersionsRoulement0 End Set End Property Public WriteOnly Property sFormatVersionsArch$() Set(sFormatVersionsArch0$) m_sFormatVersionsArch = sFormatVersionsArch0 End Set End Property Public WriteOnly Property iPeriodeArchJours%() Set(iPeriodeArchJours0%) m_iPeriodeArchJours = iPeriodeArchJours0 End Set End Property Public WriteOnly Property iNbVersionsRoulement%() Set(iNbVersionsRoulement0%) m_iNbVersionsRoulement = iNbVersionsRoulement0 End Set End Property Public WriteOnly Property sMotDePasse$() ' 01/11/2009 Set(sMotDePasse0$) m_sMotDePasse = sMotDePasse0 End Set End Property Public WriteOnly Property bCompactRepair() As Boolean ' 16/03/2013 Set(bCompactRepair0 As Boolean) m_bCompactRepair = bCompactRepair0 End Set End Property #End Region Private Sub frmAccessBackup_Load(sender As Object, 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(sender As Object, 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(sender As Object, e As EventArgs) Handles timerFin.Tick Me.Close() : Exit Sub End Sub Private Sub Backup(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 bFichierExiste2(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 bFichierExiste2(sCheminCopie, sMsgErr) 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 bVerifierCreerDossier2(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 bSupprimerFichier2(sDest, sMsgErr) Then GoTo Fin If Not bCopierFichier2(sSrc, sDest, sMsgErr) Then GoTo Fin ' Remplacer la copie tmp par la copie finale sSrc = sCheminTmp sDest = sCheminCopie If Not bRenommerFichier2(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(sMsg$) Try Dim sCheminTrace$ = sDeduireChemin(m_sCheminTrace, Application.StartupPath) Dim sDossierTrace$ = IO.Path.GetDirectoryName(sCheminTrace) Dim sMsgErr$ = "" If Not bVerifierCreerDossier2(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(sInfo$) Me.lblInfo.Text = sInfo Application.DoEvents() End Sub Public Sub Sablier(Optional 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(sNomFichierOrig$, sTypeCopie$, 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 bFichierExiste2(sSrc, sMsgErr) AndAlso Not bRenommerFichier2(sSrc, sDest, sMsgErr) Then Return False Next i 'AfficherMsg("Copie de roulement de la base attachée terminé :" & vbCrLf & sCheminDest) Return True End Function Private Function bArchiver(sNomFichierOrig$, sTypeCopie$, 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 bCopierFichier2(sCheminSrc, sCheminDest, sMsgErr) Then Return False AfficherMsg("Archivage du fichier terminé :" & vbCrLf & sCheminDest) Return True End Function End Class modConst.vb ' Fichier modConst.vb ' ------------------- Module modConst Public ReadOnly sNomAppli$ = My.Application.Info.Title ' AccessBackup Public Const sTitreMsg$ = "AccessBackup - Gestionnaire de sauvegarde" Public Const sDateVersionAppli$ = "17/08/2024" #If DEBUG Then Public Const bDebug As Boolean = True Public Const bRelease As Boolean = False #Else Public Const bDebug As Boolean = False Public Const bRelease As Boolean = True #End If ' 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 ' 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 modDepart.vb ' Fichier modDepart.vb ' -------------------- Module modDepart Public m_sTitreMsg$ = sNomAppli Public Sub DefinirTitreApplication(sTitreMsg As String) m_sTitreMsg = sTitreMsg End Sub Public Sub Main() ' modUtilFichier peut maintenant être compilé dans une dll DefinirTitreApplication(sTitreMsg) ' 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 Dim sMsgErr$ = "" If Not bFichierExiste2(Application.StartupPath & "\ICSharpCode.SharpZipLib.dll", sMsgErr, bPrompt:=True) Then Exit Sub If Not bFichierExiste2(Application.StartupPath & "\adodb.dll", sMsgErr, 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 modUtil.vb ' Fichier modUtil.vb ' ------------------ Module modUtil Public Function iConvertir%(sVal$, 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(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 Return True Return False 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 Return True Return False End Function Public Function sFormater$(iVal%, 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, sClasse$, ByRef sMsgErr$, Optional 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) Return 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) Return False End Try End Function Public Sub AfficherMsgErreur(ByRef Erreur As Microsoft.VisualBasic.ErrObject, Optional sTitreFct$ = "", Optional sInfo$ = "", Optional 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 sTitreFct$ = "", Optional sInfo$ = "", Optional sDetailMsgErr$ = "", Optional 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(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 Public Function asArgLigneCmd(sLigneCmd$, Optional bSupprimerEspaces As Boolean = True) As String() ' Retourner les arguments de la ligne de commande ' 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 ' Réutilisation de cette fonction pour parser les "" : ' -------------------------------------------------- ' Cette fonction ne respecte pas le nombre de colonne, elle parse seulement les "" correctement ' (on pourrait cependant faire une option pour conserver les colonnes vides) ' Cette fonction ne sait pas non plus parser correctement une seconde ouverture de "" entre ; ' tel que : xxx;"x""x";xxx ou "xxx";"x""x";"xxx" ' En dehors des guillemets, le séparateur est l'espace et non le ; ' -------------------------------------------------- Dim asArgs$() = Nothing If String.IsNullOrEmpty(sLigneCmd) Then ReDim asArgs(0) asArgs(0) = "" asArgLigneCmd = asArgs Exit Function End If ' Parser les noms cours : facile 'asArgs = Split(Command, " ") Dim lstArgs As New List(Of String) ' 16/10/2016 Const sGm$ = """" ' Un seul " en fait 'sGm = Chr$(34) ' Guillemets Dim sFichier$, sSepar$ Dim sCmd$, iLongCmd%, iFin%, iDeb%, iDeb2% Dim bFin As Boolean, bNomLong As Boolean Dim iCarSuiv% = 1 sCmd = sLigneCmd iLongCmd = Len(sCmd) iDeb = 1 Do bNomLong = False : sSepar = " " ' Chaîne vide : "" Dim s2Car$ = Mid(sCmd, iDeb, 2) If s2Car = sGm & sGm Then bNomLong = True : sSepar = sGm iFin = iDeb + 1 GoTo Suite End If ' Si le premier caractère est un guillement, c'est un nom long Dim sCar$ = Mid(sCmd, iDeb, 1) 'Dim iCar% = Asc(sCar) ' Pour debug If sCar = sGm Then bNomLong = True : sSepar = sGm iDeb2 = iDeb ' Supprimer les guillemets dans le tableau de fichiers If bNomLong AndAlso iDeb2 < iLongCmd Then iDeb2 += 1 ' Gestion chaîne vide iFin = InStr(iDeb2 + 1, sCmd, sSepar) ' 16/10/2016 On tolère que un " peut remplacer un espace iCarSuiv = 1 Dim iFinGM% = InStr(iDeb2 + 1, sCmd, sGm) If iFinGM > 0 AndAlso iFin > 0 AndAlso iFinGM < iFin Then iFin = iFinGM : bNomLong = True : sSepar = sGm : iCarSuiv = 0 End If ' Si le séparateur n'est pas trouvé, c'est la fin de la ligne de commande If iFin = 0 Then bFin = True : iFin = iLongCmd + 1 sFichier = Mid(sCmd, iDeb2, iFin - iDeb2) If bSupprimerEspaces Then sFichier = Trim(sFichier) If sFichier.Length > 0 Then lstArgs.Add(sFichier) If bFin OrElse iFin = iLongCmd Then Exit Do Suite: iDeb = iFin + iCarSuiv ' 1 ' 16/10/2016 On tolère que un " peut remplacer un espace, plus besoin 'If bNomLong Then iDeb = iFin + 2 If iDeb > iLongCmd Then Exit Do ' 09/10/2014 Gestion chaîne vide Loop asArgs = lstArgs.ToArray() Const iCodeGuillemets% = 34 For iNumArg As Integer = 0 To UBound(asArgs) Dim sArg$ = asArgs(iNumArg) ' S'il y avait 2 guillemets, il n'en reste plus qu'un ' on le converti en chaîne vide Dim iLong0% = Len(sArg) If iLong0 = 1 AndAlso Asc(sArg.Chars(0)) = iCodeGuillemets Then asArgs(iNumArg) = "" Next iNumArg asArgLigneCmd = asArgs End Function End Module modUtilDAO.vb ' Fichier modUtilDAO.vb ' --------------------- Module modUtilDAO Public Function iNbUtilisateurs%(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 bPromptErr As Boolean = False, Optional 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) ' - Il faut compiler en mode 32 bits, car cela ne marche pas en 64 bits : ' Mettre <PlatformTarget>x86</PlatformTarget> dans AccessBackup.vbproj (25/05/2013) 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(oVal As Object, Optional 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 Const sClsDAOEngineCompactage$ = "DAO.DBEngine.36" ' C'est bien la dernière version dispo. Public Function bCompacterMdb(sCheminBaseSrc$, ByRef sMsgErr$, Optional sCheminBaseDest$ = "", Optional bPromptErr As Boolean = False, Optional 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 bSupprimerFichier2(sCheminBaseDest, sMsgErr) Then Return False ' On a une exception ici, mais l'objet oDBE est tout de même créé, le compactage fonctionne ' Assistant Débogage managé 'BindingFailure' ' Message=Assistant Débogage managé 'BindingFailure' : ' L'assembly avec le nom complet 'dao' n'a pas pu se charger dans le contexte de liaison 'LoadFrom' ' de l'AppDomain ayant l'ID 1. La cause de l'erreur était : System.IO.FileNotFoundException: ' Impossible de charger le fichier ou l'assembly ' 'dao, Version=10.0.4504.0, Culture=neutral, PublicKeyToken=31bf3856ad364e35' ' ou une de ses dépendances. Le fichier spécifié est introuvable.' ' La dll est pourtant là : "C:\Program Files (x86)\Common Files\Microsoft Shared\DAO\dao360.dll" Dim oDBE As Object = Nothing If Not bCreerObjet(oDBE, sClsDAOEngineCompactage, sMsgErr) Then Return False 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) Return False Finally oDBE = Nothing End Try If bRetablirNom Then ' Rétablir le nom d'origine du fichier If Not bRenommerFichier2(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 bSupprimerFichier2(sCheminBaseDest, sMsgErr0) Then Return False Return False End If End If Return True End Function End Module modUtilFichierAvecGestionErrParMsg.vb ' Les fonctions qui existent déjà dans modUtilFichier sont numérotées avec 2 Module modUtilFichierAvecGestionErrParMsg Const sCauseErrPoss$ = "Le fichier est peut-être protégé en écriture ou bien verrouillé par une autre application" Public Function bFichierExiste2(sCheminFichier$, ByRef sMsgErr$, Optional 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 bFichierExiste2 = IO.File.Exists(sCheminFichier) If bFichierExiste2 Then Exit Function sMsgErr = "Impossible de trouver le fichier :" & vbCrLf & sCheminFichier If bPrompt Then MsgBox(sMsgErr, MsgBoxStyle.Critical, sTitreMsg & " - Fichier introuvable") End Function Public Function bSupprimerFichier2(sCheminFichier$, ByRef sMsgErr$, Optional bPromptErr As Boolean = False) As Boolean ' Vérifier si le fichier existe If Not bFichierExiste2(sCheminFichier, sMsgErr) Then Return True ' Supprimer le fichier Try IO.File.Delete(sCheminFichier) Return 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, "bSupprimerFichier2", sMsg) Return False End Try End Function Public Function bCopierFichier2(sSrc$, sDest$, ByRef sMsgErr$, Optional bPromptErr As Boolean = False) As Boolean Try IO.File.Copy(sSrc, sDest) Return 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, "bCopierFichier2", sMsg) Return False End Try End Function Public Function bRenommerFichier2(sSrc$, sDest$, ByRef sMsgErr$, Optional bPromptErr As Boolean = False) As Boolean If Not bFichierExiste2(sSrc, sMsgErr) Then Return False If Not bSupprimerFichier2(sDest, sMsgErr) Then Return False Try IO.File.Move(sSrc, sDest) Return 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, "bRenommerFichier2", sMsg) Return False End Try End Function Public Function bVerifierCreerDossier2(ByRef sCheminDossier$, ByRef sMsgErr$, Optional bPromptErr As Boolean = False) As Boolean ' Vérifier et créer le dossier If sCheminDossier = "" Then Return True 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") Return False End If Return True Catch ex As Exception sMsgErr = sMsgErr0 & vbCrLf & ex.Message If bPromptErr Or bPromptErrGlob Then _ AfficherMsgErreur2(ex, "bVerifierCreerDossier2", sMsgErr0) Return False End Try End Function Public Function sDossierRacine$(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$(sDossier$, sCheminCourant$) ' Déuire 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(sCheminZip$, sCheminFichier$, ByRef sMsgErr$, Optional 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() Return 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) Return False End Try End Function End Module