1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192
| '------------------------------------------------------------------------------------------------------
Public Function OuvrirClasseur(Fichier As String, _
Visible As Boolean, _
Optional MotDePasseOuverture As String = "", _
Optional MotDePasseEcriture As String = "", _
Optional MAJ_Liens As Boolean = False, _
Optional DésactiveMacros As Boolean = True) As Workbook
'------------------------------------------------------------------------------------------------------
' Ouvre un classeur Excel en le mettant invisible si "Visible" = False pour que l'utilisateur ne soit pas perturbé par les
' manipulations qui y sont faites. Un fichier en lecture seule peut être modifié car la fonction fait sauter
' cet attribut temporairement puis le remet à la fermeture par la fonction "FermerClasseur".
'------------------------------------------------------------------------------------------------------
' Fichier : le classeur Excel qu'il faut ouvrir (chemin complet + nom avec l'extension).
' Visible : False pour masquer le classeur.
' MotDePasseOuverture : éventuellement le mot de passe pour ouvrir le fichier (vide si non nécessaire).
' MotDePasseEcriture : éventuellement le mot de passe pour modifier le fichier (vide si non nécessaire).
' MAJ_Liens : mettre Vrai s'il faut faire une mise à jour des liens à l'ouverture du classeur.
' DésactiveMacros : mettre Vrai pour désactiver les macros et les événements y compris Workbook_Open.
'------------------------------------------------------------------------------------------------------
' La fonction renvoie l'objet Workbook du classeur si tout s'est bien passé.
'------------------------------------------------------------------------------------------------------
' Exemple d'utilisation pour remplacer les données du tableau "TS_Eleves" contenues dans le classeur
' "C:\Users\ott_l\Downloads\Test_TS.xlsm" sur la feuille "Feuil1" par les données du tableau "TS_Eleves"
' du classeur "C:\Users\ott_l\Downloads\Classeur_Elèves.xlsx" en feuille "Feuil1":
'
'On Error GoTo Gest_Err
'Err.Clear
'
'Dim Wk_S As Workbook
'Set Wk_S = OuvrirClasseur("C:\Users\ott_l\Downloads\Classeur_Elèves.xlsx", False)
'
'Dim Wk_D As Workbook
'Set Wk_D = OuvrirClasseur("C:\Users\ott_l\Downloads\Test_TS.xlsm", False)
'
'Dim TS As Range: Set TS = Wk_S.Sheets("Feuil1").Range("TS_Eleves")
'Dim TD As Range: Set TD = Wk_D.Sheets("Feuil1").Range("TS_Eleves")
'
'Call TS_CopierUnTableau(TS, TD, TS_RemplacerDonnées, TS_Valeurs)
'Call TS_FormatColonne(TD, "Note", "0.0", True)
'
'Call FermerClasseur(Wk_S, False)
'Call FermerClasseur(Wk_D, True)
'
'MsgBox "fin"
'
'Gest_Err:
'If Err.Number <> 0 Then
' MsgBox Err.Number & " : " & Err.Description, vbExclamation
' Call FermerClasseur(Wk_S, False)
' Call FermerClasseur(Wk_D, True)
'End If
'Err.Clear
'------------------------------------------------------------------------------------------------------
Dim Wk As Workbook
Dim Filenum As Long
Dim ObjFile As Object
Dim Anc_ScreenUpdating As Boolean
Dim Attributs As Long
Dim Anc_Wk As Workbook
' Gestion des erreurs:
On Error GoTo Gest_Err
Err.Clear
' Bloque la mise à jour de l'écran:
Anc_ScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
' Mémorise le classeur actif:
Set Anc_Wk = ActiveWorkbook
' Une erreur est déclenchée si le fichier source n'est pas trouvé:
Set ObjFile = CreateObject("Scripting.FileSystemObject").GetFile(Fichier)
' Supprime l'attribut lecture seule:
Attributs = ObjFile.Attributes
ObjFile.Attributes = 0
' Une erreur est déclenchée s'il est déjà ouvert:
Filenum = FreeFile()
Open Fichier For Binary Lock Read Write As #Filenum
Close Filenum
' Désactive les macros pour ouvrir le fichier sans lancer "Workbook_Open":
If UCase(Right(Fichier, 5)) <> ".XLSX" And DésactiveMacros = True Then
Dim secAutomation As MsoAutomationSecurity
secAutomation = Application.AutomationSecurity
Application.AutomationSecurity = msoAutomationSecurityForceDisable
' Ouvre le fichier (sans mettre à jour les liens si MAJ_Liens=False):
Set Wk = Workbooks.Open(Fichier, MAJ_Liens, False, , MotDePasseOuverture, MotDePasseEcriture, True)
' Réactive les macros:
Application.AutomationSecurity = secAutomation
Else
' Ouvre le fichier (sans mettre à jour les liens si MAJ_Liens=False):
Set Wk = Workbooks.Open(Fichier, MAJ_Liens, False, , MotDePasseOuverture, MotDePasseEcriture, True)
End If
' Masque le classeur que l'on vient d'ouvrir:
Windows(Wk.Name).Visible = Visible
' Restaure l'attribut d'origine:
ObjFile.Attributes = Attributs
' Restaure le classeur appelant:
Anc_Wk.Activate
' Renvoie le classeur:
Set OuvrirClasseur = Wk
' Gestion des erreurs:
Gest_Err:
Application.ScreenUpdating = Anc_ScreenUpdating
If Err.Number <> 0 Then
If Not ObjFile Is Nothing Then ObjFile.Attributes = Attributs
Err.Raise Err.Number
End If
End Function
'------------------------------------------------------------------------------------------------------
Public Function FermerClasseur(Classeur As Workbook, Enregistrer As Boolean) As Boolean
'------------------------------------------------------------------------------------------------------
' Ferme un classeur (normalement préalablement ouvert avec OuvrirClasseur) et l'enregistre ou non.
'------------------------------------------------------------------------------------------------------
' Classeur : l'objet Workbook à fermer.
' Enregistrer : Vrai s'il faut enregistrer le classeur.
'------------------------------------------------------------------------------------------------------
' Renvoie : VRAI si tout s'est bien passé.
'------------------------------------------------------------------------------------------------------
Dim ObjFile As Object
Dim Anc_ScreenUpdating As Boolean
Dim Attributs As Long
' Gestion des erreurs:
On Error GoTo Gest_Err
Err.Clear
' Bloque la mise à jour de l'écran:
Anc_ScreenUpdating = Application.ScreenUpdating
Application.ScreenUpdating = False
' Si le classeur est toujours actif:
If TypeName(Classeur) = "Workbook" Then
' S'il faut l'enregistrer:
If Enregistrer = True Then
' Une erreur est déclenchée si le fichier source n'est pas trouvé:
Set ObjFile = CreateObject("Scripting.FileSystemObject").GetFile(Classeur.FullName)
' Mémorise l'attribut du fichier puis supprime la lecture seule:
Attributs = ObjFile.Attributes
ObjFile.Attributes = 0
Windows(Classeur.Name).Visible = True
Classeur.Activate
Application.WindowState = xlMinimized
Classeur.Save
' Restaure l'attribut:
ObjFile.Attributes = Attributs
End If
' Ferme le fichier:
Classeur.Saved = True
Classeur.Close
' Renvoie Vrai:
FermerClasseur = True
End If
' Gestion des erreurs:
Gest_Err:
Application.ScreenUpdating = Anc_ScreenUpdating
If Err.Number <> 0 Then Err.Raise Err.Number
End Function
'------------------------------------------------------------------------------------------------
Public Function TS_RangeDansClasseur(Classeur As Workbook, TS_Nom As String) As Range
'------------------------------------------------------------------------------------------------
Dim Ws, Ref
For Each Ws In Classeur.Worksheets
For Each Ref In Ws.ListObjects
If Ref.Name = TS_Nom Then
Set TS_RangeDansClasseur = Classeur.Sheets(Ws.Name).Range(TS_Nom): Exit Function
End If
Next Ref
Next Ws
Err.Raise vbObjectError, "TS_RangeDansClasseur", "Le tableau [" & TS_Nom & "] n'est pas trouvé dans le classeur " & Classeur.FullName & "."
End Function
'------------------------------------------------------------------------------------------------
'------------------------------------------------------------------------------------------------ |
Partager