Répérer les classeurs contenant des macro

[tyuiop]

Comme je dois changer de boulot j'aimerais sauvegarder à part les classeurs xls 2003 contenant des macros.

Peut on les repérer d'une façon automatique ?

 

[Dranreb]

Re : Répérer les classeurs contenant des macro

Bonjour.
Oui, vous pouvez analyser la collection VBProject.VBComponents des classeurs.
Chaque élément VBComponent a une propriété Type qui vaut autre chose que 100 s'il n'est pas parmi les "Microsoft Excel Objets". S'il en fait partie, la propriété CodeModule vous permettra de vérifier s'il y a des procédures dedans.
La référence "Microsoft Visual Basic for Application Extensiblity 5.3" pourra vous être d'une grande aide.
Cordialement.

 

[MichD]

Re : Répérer les classeurs contenant des macro

Bonjour,

Copie tout le code suivant dans le haut d'un module standard.
Définis les variables dans la procédure : Déplacer_Fichier_Avec_Macro

L'objectif étant de déplacer dans le répertoire de destination tous les fichiers Excel
ayant du code dans leur module. Attention, si un fichier a un module, mais que ce
module est vide, il n'est pas considéré comme ayant une macro. Cependant, pour
Excel, la seule présence d'un module même vide est suffisante pour déclencher l'alerte
à l'ouverture du fichier à savoir si l'usager doit activer les macros. Aucune modification
n'est effectuée sur les classeurs ouverts.


'déclaration des variables, constantes et Api dans le haut d'un
'module standard :
Type SHFILEOPSTRUCT
hwnd As Long
wFunc As Long
pFrom As String
pTo As String
fFlags As Integer
fAnyOperationsAborted As Boolean
hNameMappings As Long
lpszProgressTitle As String
End Type

Const FO_MOVE = 1
Const FOF_SILENT = 4
Const FOF_NOCONFIRMATION = 10

Private Declare Function SHFileOperationA Lib "Shell32.dll" _
(lpFileOp As SHFILEOPSTRUCT) As Long

Private Function DéplaceFichier(Source As String, Dest As String, _
Optional Action As Byte, Optional Animation As Boolean) As Boolean
Dim OpStruct As SHFILEOPSTRUCT

With OpStruct
.wFunc = Action
.pFrom = Source
.pTo = Dest
'POUR MESSAGE AVANT D'ÉCRASER : 4 AU LIEU DE 10
'Si dans le répertoire de destination, un fichier du même
'nom existe, 10 pour un avertissement, 4 sans avertissement
'avant de déplacer le fichier
.fFlags = 10
End With
DéplaceFichier = IIf(SHFileOperationA(OpStruct), False, True)
End Function

'---------------------------------------------
Sub SupprimeToutCodeEtFormulaire()

Dim Repertoire As String
Dim Fichier As String, Wk As Workbook
Dim Dest As String

'******VARIABLES À DÉFINIR**********
'où seront déplacés les fichiers avec Macro
Dest = "c:\Chemin\FichierExcelAvecMacro\"
'Répertoire où sont tous les fichiers Excel
Repertoire = "c:\Chemin\"
'******VARIABLES À DÉFINIR**********

Fichier = Dir(Repertoire & "*.xl*")
Do While Fichier <> ""
Set Wk = Workbooks.Open(Repertoire & Fichier)
If ACodeExistant(Wk) Then

Wk.Close False
DéplaceFichier Repertoire & Fichier, Dest, FO_MOVE, True
End If
Fichier = Dir()
Loop

End Sub
'---------------------------------------------

Function ACodeExistant(Wk As Workbook) As Boolean
Dim VBComp As Object
Dim VBComps As Object

Set VBComps = Wk.VBProject.VBComponents
For Each VBComp In VBComps
x = VBComp.Name
Select Case VBComp.Type
Case 100 ' thisWorkbook, Feuille
With VBComp.CodeModule
If .CountOfLines > 0 Then
If Application.Substitute(Trim _
(.Lines(1, .CountOfLines)), vbCrLf, "") <> "" Then
ACodeExistant = True
Exit For
End If
End If
End With
Case Else
With VBComp.CodeModule
If .CountOfLines > 0 Then
If Application.Substitute(Trim _
(.Lines(1, .CountOfLines)), vbCrLf, "") <> "" Then
ACodeExistant = True
Exit For
End If
End If
End With
End Select
Next
End Function
'---------------------------------------------