bonjour,
Microsoft Visual Basic Editor permet l'insertion de lignes de déclarations dans les feuilles de code, mais à ma connaissance ne permet pas d'insérer un en-tête indiquant l'auteur, la date, le but, les fonctions/procédures utilisées ....
Des add-ins permettent cela mais sont plus ou moins bien et plus ou moins facilement paramétrables. Certains gèrent les modèles d'en-tête à l'aide de fichiers XML ou XSD, mais j'ai dû mal avec ça ;-)
Du coup, j'essaye pour le plaisir de bidouiller, voilà donc mes débuts.
Le principe fonctionne mais mes routines ratent la moitié des procédures.
Public Enum VBALineType
VBALine_Blank = 0
VBALine_Comment = 1
VBALine_LibraryFunction = 2
VBALine_Procedure = 3
VBALine_Function = 4
End Enum
Const TPL_DIVIDER_DASH = "'---------------------------------------------------------------------------------------"
Const TPL_MODULE_NAME = "' Module : "
Const TPL_MODULE_AUTHOR = "' Author : "
Const TPL_MODULE_DATE = "' Date : "
Const TPL_MODULE_PURPOSE = "' Purpose : "
Const TPL_MARKER2FIND = "Option Explicit" 'Used in procedure VBE_TPL_INSERT
Const TPL_FORMAT_DATE = "DDDD DD MMMM YYYY"
Private Sub DeleteDummyKeys(ByVal vsGUID As String, ByVal vsVersion As String)
Sub VBE_TPL_INSERT_DEMO()
Call VBE_TPL_INSERT(varWorkbook:=ThisWorkbook, DeleteOldLines:=True, InsertRoutinesList:=True) , ConcernedVBComponents:=Array("ThisWorkbook", "Module1"))
End Sub
'=========== LA PRINCIPALE PROCEDURE
Sub VBE_TPL_INSERT(Optional Marker2Find As String = TPL_MARKER2FIND, _
Optional DeleteOldLines As Boolean, _
Optional InsertRoutinesList As Boolean, _
Optional ConcernedVBComponents As Variant, _
Optional varWorkbook As Variant, _
Optional ModuleAuthor As String, _
Optional ModuleDate As Variant, _
Optional ModulePurpose As String, _
Optional LineAtTop As String = TPL_DIVIDER_DASH, _
Optional LineAtBottom As String = TPL_DIVIDER_DASH)
'Solution designed by STephane
'This solution requires the below constants
'Const TPL_DIVIDER_DASH = "'---------------------------------------------------------------------------------------"
'Const TPL_MODULE_NAME= "' Module : "
'Const TPL_MODULE_AUTHOR = "' Author : "
'Const TPL_MODULE_DATE = "' Date : "
'Const TPL_MODULE_PURPOSE = "' Purpose : "
'Const TPL_NAME = ""
'Const TPL_MARKER2FIND = "Option Explicit" 'Used in procedure VBE_TPL_INSERT
'Const TPL_FORMAT_DATE="DDDD DD MMMM YYYY"
Dim MarkerLine As Long 'ligne du délimiteur pour l'insertion du template
Dim MarkerFound As Variant 'pour rechercher le délimiteur
Dim CodeLines As String 'pour manipuler les lignes de code
Dim VBCompColl As New Collection 'collection de modules qui comprendra tous les modules du projet,
Dim ConcernedComponent As Variant ' ou bien ceux donnés à spécifier dans l'appel de la fonction
Dim VBCodeMod As VBIDE.CodeModule '
Dim VBCompModule As VBIDE.CodeModule '
Dim lstartline As Long, lcount As Long, LinesCnt As Long 'index & compteurs
'French comment : Le classeur traité est le classeur actif ou bien le classeur passé en paramètre.
'Si le paramètre est passé et de type chaîne, il faut intervenir pour créer la variable objet.
'English comment :
'The processed workbook is the active one or the parameter-passed workbook.
'In case the parameter is kind of string, we have to create the object variable.
If Not IsMissing(varWorkbook) And TypeName(varWorkbook) = "string" Then
Set varWorkbook = Workbooks(varWorkbook)
ElseIf IsMissing(varWorkbook) = True Then
Set varWorkbook = ActiveWorkbook
End If
'French comment : quelques instructions qui pourraient évoluer vers la gestion d'un éventuel modèle d'en-tête externe
'English comment : some instructions line that could evolve to manage external header template
Dim ExternalFile As Variant
If IsMissing(ExternalFile) Or IsEmpty(ExternalFile) Then
ModuleAuthor = TPL_MODULE_AUTHOR & IIf(ModuleAuthor <> "", ModuleAuthor, Application.UserName)
ModuleDate = TPL_MODULE_DATE & Application.WorksheetFunction.Proper(Format(IIf(IsMissing(ModuleDate) = False, ModuleDate, Date), TPL_FORMAT_DATE))
End If
'Trvail sur le projet visual Basic / Work on the visual basic project
With varWorkbook.VBProject
'French comment :
' détermination des modules à processer, soit tous soit ceux passés dans l'appel,
' et mémorisation dans une collection
'English comment :
' determining modules to be processed, either all of them, either these transmitted in the function call,
' and also memorizing them into a collection
If Not IsMissing(ConcernedVBComponents) Then
For Each ConcernedComponent In ConcernedVBComponents
Set VBCompModule = .VBComponents(ConcernedComponent).CodeModule
VBCompColl.Add Item:=VBCompModule
Next ConcernedComponent
Else
For Each ConcernedComponent In varWorkbook.VBProject.VBComponents
Set VBCompModule = ConcernedComponent.CodeModule
VBCompColl.Add Item:=VBCompModule
Next ConcernedComponent
End If
'French comment : boucle sur les fichiers à processer
'English comment : loop on modules to be processed
For Each VBCompModule In VBCompColl
With VBCompModule
CodeLines = LineAtTop & vbCr & _
TPL_MODULE_NAME & .Parent.name & vbCr & _
ModuleAuthor & vbCr & ModuleDate & vbCr & _
TPL_MODULE_PURPOSE & vbCr & LineAtBottom & vbCr & "'"
'Recherche de la chaîne avant laquelle insérer le modèle
'Finding the line before which the template is to be inserted
If Not IsMissing(Marker2Find) Then
For MarkerLine = 1 To .CountOfLines
MarkerFound = .Find(Marker2Find, MarkerLine, 1, .CountOfLines, -1) ' True, False, False)
If MarkerFound = True Then Exit For
Next
End If
If DeleteOldLines Then
If MarkerLine > 1 Then
LinesCnt = MarkerLine - 1
VBCompModule.DeleteLines 1, LinesCnt
MarkerLine = 1
End If
End If
'insérer le template s'il y a des lignes de déclaration
If .CountOfDeclarationLines = 0 Then GoTo nnext
'insérer le template
.InsertLines MarkerLine, CodeLines
'insertion de la liste de procédures
If InsertRoutinesList Then
MarkerLine = MarkerLine + 6 + 1 '6= nb de lignes du template
Call VBE_TPL_BuildRoutinesList(VBCompModule, MarkerLine)
End If
End With
nnext:
'Next i
Next VBCompModule
End With
End Sub
'========== FIN DE LA PROCEDURE
Function vbe_LineInfo(ModuleObject As VBIDE.CodeModule, TheLine As Long) As VBALineType
'Solution designed by STephane
Dim AllKinds As New Collection
AllKinds.Add vbext_pk_Get
AllKinds.Add vbext_pk_Set
AllKinds.Add vbext_pk_Let
AllKinds.Add vbext_pk_Proc
Dim LaLigne As String
LaLigne = ModuleObject.Lines(TheLine, 1)
If Trim(LaLigne) = vbNullString Then vbe_LineInfo = 0: Exit Function
If Left(Trim(LaLigne), 1) = "'" Then vbe_LineInfo = 1: Exit Function
If InStr(1, LaLigne, " Declare Function ") Then vbe_LineInfo = 2: Exit Function
For i = 1 To AllKinds.count
If Len(ModuleObject.ProcOfLine(TheLine, AllKinds(i))) Then
If InStr(1, LaLigne, " Function ") Then
vbe_LineInfo = 3
ElseIf InStr(1, LaLigne, " Sub ") Then
vbe_LineInfo = 4
End If
Exit Function
End If
Next i
End Function
Function VBE_TPL_BuildRoutinesList(ModuleObject As VBIDE.CodeModule, TheLine As Long) As Variant
'Dresser la liste des procédures et fonctions
Dim F_LF As Boolean, F_F As Boolean, F_P As Boolean
Dim ProcKind As VBIDE.vbext_ProcKind
Dim VBA_LibraryFunctions() As Variant
Dim VBA_Procedures() As Variant
Dim VBA_Functions() As Variant
Dim RoutinesList As Variant
Dim ProcName As String
Dim LineNum As Long
Dim DimArray As Long
On Error Resume Next
ReDim Preserve VBA_Functions(0)
ReDim Preserve VBA_LibraryFunctions(0)
ReDim Preserve VBA_Procedures(0)
With ModuleObject
'la liste généré est à incomplete, 2 facteurs peut-être :
' - le compte de lignes de déclaration
' - regarder du côté de vbe_lineinfo
For LineNum = 1 To .CountOfLines
ProcName = .ProcOfLine(LineNum, ProcKind)
If ProcName <> "" Then
Select Case vbe_LineInfo(ModuleObject, LineNum)
Case VBALine_Function
F_F = True
If IsEmpty(VBA_Functions(0)) = False Then _
ReDim Preserve VBA_Functions(UBound(VBA_Functions) + 1)
VBA_Functions(UBound(VBA_Functions)) = "'" & vbTab & ProcName
Case VBALine_LibraryFunction
F_LF = True
If IsEmpty(VBA_LibraryFunctions(0)) = False Then _
ReDim Preserve VBA_LibraryFunctions(UBound(VBA_LibraryFunctions))
VBA_LibraryFunctions(UBound(VBA_LibraryFunctions)) = "'" & vbTab & ProcName
Case VBALine_Procedure
F_P = True
If IsEmpty(VBA_Procedures(0)) = False Then _
ReDim Preserve VBA_Procedures(UBound(VBA_Procedures))
VBA_Procedures(UBound(VBA_Procedures)) = "'" & vbTab & ProcName
End Select
End If
Next LineNum
End With
RoutinesList = IIf(F_LF = True, "' Library Functions : <<" & vbCr & Join(VBA_LibraryFunctions, vbCr) & vbCr & "' >>" & vbCr, "") _
& IIf(F_F = True, "' Functions : <<" & vbCr & Join(VBA_Functions, vbCr) & vbCr & "' >>" & vbCr, "") _
& IIf(F_P = True, "' Procedures : <<" & vbCr & Join(VBA_Procedures, vbCr) & vbCr & "' >>" & vbCr & "'", "")
If RoutinesList <> "" Then
ModuleObject.InsertLines TheLine, RoutinesList
End If
End Function
j'avais aussi créé cette fonction
Function vbe_IsRoutineDeclaration(ModuleObject As VBIDE.CodeModule, TheLine As Long) As Boolean
'Solution designed by STephane
Dim AllKinds As New Collection
AllKinds.Add vbext_pk_Get
AllKinds.Add vbext_pk_Set
AllKinds.Add vbext_pk_Let
AllKinds.Add vbext_pk_Proc
For i = 1 To AllKinds.count
If Len(ModuleObject.ProcOfLine(TheLine, AllKinds(i))) Then
vbe_IsRoutineDeclaration = True
Exit Function
End If
Next i
End Function
Microsoft Visual Basic Editor permet l'insertion de lignes de déclarations dans les feuilles de code, mais à ma connaissance ne permet pas d'insérer un en-tête indiquant l'auteur, la date, le but, les fonctions/procédures utilisées ....
Des add-ins permettent cela mais sont plus ou moins bien et plus ou moins facilement paramétrables. Certains gèrent les modèles d'en-tête à l'aide de fichiers XML ou XSD, mais j'ai dû mal avec ça ;-)
Du coup, j'essaye pour le plaisir de bidouiller, voilà donc mes débuts.
Le principe fonctionne mais mes routines ratent la moitié des procédures.
Public Enum VBALineType
VBALine_Blank = 0
VBALine_Comment = 1
VBALine_LibraryFunction = 2
VBALine_Procedure = 3
VBALine_Function = 4
End Enum
Const TPL_DIVIDER_DASH = "'---------------------------------------------------------------------------------------"
Const TPL_MODULE_NAME = "' Module : "
Const TPL_MODULE_AUTHOR = "' Author : "
Const TPL_MODULE_DATE = "' Date : "
Const TPL_MODULE_PURPOSE = "' Purpose : "
Const TPL_MARKER2FIND = "Option Explicit" 'Used in procedure VBE_TPL_INSERT
Const TPL_FORMAT_DATE = "DDDD DD MMMM YYYY"
Private Sub DeleteDummyKeys(ByVal vsGUID As String, ByVal vsVersion As String)
Sub VBE_TPL_INSERT_DEMO()
Call VBE_TPL_INSERT(varWorkbook:=ThisWorkbook, DeleteOldLines:=True, InsertRoutinesList:=True) , ConcernedVBComponents:=Array("ThisWorkbook", "Module1"))
End Sub
'=========== LA PRINCIPALE PROCEDURE
Sub VBE_TPL_INSERT(Optional Marker2Find As String = TPL_MARKER2FIND, _
Optional DeleteOldLines As Boolean, _
Optional InsertRoutinesList As Boolean, _
Optional ConcernedVBComponents As Variant, _
Optional varWorkbook As Variant, _
Optional ModuleAuthor As String, _
Optional ModuleDate As Variant, _
Optional ModulePurpose As String, _
Optional LineAtTop As String = TPL_DIVIDER_DASH, _
Optional LineAtBottom As String = TPL_DIVIDER_DASH)
'Solution designed by STephane
'This solution requires the below constants
'Const TPL_DIVIDER_DASH = "'---------------------------------------------------------------------------------------"
'Const TPL_MODULE_NAME= "' Module : "
'Const TPL_MODULE_AUTHOR = "' Author : "
'Const TPL_MODULE_DATE = "' Date : "
'Const TPL_MODULE_PURPOSE = "' Purpose : "
'Const TPL_NAME = ""
'Const TPL_MARKER2FIND = "Option Explicit" 'Used in procedure VBE_TPL_INSERT
'Const TPL_FORMAT_DATE="DDDD DD MMMM YYYY"
Dim MarkerLine As Long 'ligne du délimiteur pour l'insertion du template
Dim MarkerFound As Variant 'pour rechercher le délimiteur
Dim CodeLines As String 'pour manipuler les lignes de code
Dim VBCompColl As New Collection 'collection de modules qui comprendra tous les modules du projet,
Dim ConcernedComponent As Variant ' ou bien ceux donnés à spécifier dans l'appel de la fonction
Dim VBCodeMod As VBIDE.CodeModule '
Dim VBCompModule As VBIDE.CodeModule '
Dim lstartline As Long, lcount As Long, LinesCnt As Long 'index & compteurs
'French comment : Le classeur traité est le classeur actif ou bien le classeur passé en paramètre.
'Si le paramètre est passé et de type chaîne, il faut intervenir pour créer la variable objet.
'English comment :
'The processed workbook is the active one or the parameter-passed workbook.
'In case the parameter is kind of string, we have to create the object variable.
If Not IsMissing(varWorkbook) And TypeName(varWorkbook) = "string" Then
Set varWorkbook = Workbooks(varWorkbook)
ElseIf IsMissing(varWorkbook) = True Then
Set varWorkbook = ActiveWorkbook
End If
'French comment : quelques instructions qui pourraient évoluer vers la gestion d'un éventuel modèle d'en-tête externe
'English comment : some instructions line that could evolve to manage external header template
Dim ExternalFile As Variant
If IsMissing(ExternalFile) Or IsEmpty(ExternalFile) Then
ModuleAuthor = TPL_MODULE_AUTHOR & IIf(ModuleAuthor <> "", ModuleAuthor, Application.UserName)
ModuleDate = TPL_MODULE_DATE & Application.WorksheetFunction.Proper(Format(IIf(IsMissing(ModuleDate) = False, ModuleDate, Date), TPL_FORMAT_DATE))
End If
'Trvail sur le projet visual Basic / Work on the visual basic project
With varWorkbook.VBProject
'French comment :
' détermination des modules à processer, soit tous soit ceux passés dans l'appel,
' et mémorisation dans une collection
'English comment :
' determining modules to be processed, either all of them, either these transmitted in the function call,
' and also memorizing them into a collection
If Not IsMissing(ConcernedVBComponents) Then
For Each ConcernedComponent In ConcernedVBComponents
Set VBCompModule = .VBComponents(ConcernedComponent).CodeModule
VBCompColl.Add Item:=VBCompModule
Next ConcernedComponent
Else
For Each ConcernedComponent In varWorkbook.VBProject.VBComponents
Set VBCompModule = ConcernedComponent.CodeModule
VBCompColl.Add Item:=VBCompModule
Next ConcernedComponent
End If
'French comment : boucle sur les fichiers à processer
'English comment : loop on modules to be processed
For Each VBCompModule In VBCompColl
With VBCompModule
CodeLines = LineAtTop & vbCr & _
TPL_MODULE_NAME & .Parent.name & vbCr & _
ModuleAuthor & vbCr & ModuleDate & vbCr & _
TPL_MODULE_PURPOSE & vbCr & LineAtBottom & vbCr & "'"
'Recherche de la chaîne avant laquelle insérer le modèle
'Finding the line before which the template is to be inserted
If Not IsMissing(Marker2Find) Then
For MarkerLine = 1 To .CountOfLines
MarkerFound = .Find(Marker2Find, MarkerLine, 1, .CountOfLines, -1) ' True, False, False)
If MarkerFound = True Then Exit For
Next
End If
If DeleteOldLines Then
If MarkerLine > 1 Then
LinesCnt = MarkerLine - 1
VBCompModule.DeleteLines 1, LinesCnt
MarkerLine = 1
End If
End If
'insérer le template s'il y a des lignes de déclaration
If .CountOfDeclarationLines = 0 Then GoTo nnext
'insérer le template
.InsertLines MarkerLine, CodeLines
'insertion de la liste de procédures
If InsertRoutinesList Then
MarkerLine = MarkerLine + 6 + 1 '6= nb de lignes du template
Call VBE_TPL_BuildRoutinesList(VBCompModule, MarkerLine)
End If
End With
nnext:
'Next i
Next VBCompModule
End With
End Sub
'========== FIN DE LA PROCEDURE
Function vbe_LineInfo(ModuleObject As VBIDE.CodeModule, TheLine As Long) As VBALineType
'Solution designed by STephane
Dim AllKinds As New Collection
AllKinds.Add vbext_pk_Get
AllKinds.Add vbext_pk_Set
AllKinds.Add vbext_pk_Let
AllKinds.Add vbext_pk_Proc
Dim LaLigne As String
LaLigne = ModuleObject.Lines(TheLine, 1)
If Trim(LaLigne) = vbNullString Then vbe_LineInfo = 0: Exit Function
If Left(Trim(LaLigne), 1) = "'" Then vbe_LineInfo = 1: Exit Function
If InStr(1, LaLigne, " Declare Function ") Then vbe_LineInfo = 2: Exit Function
For i = 1 To AllKinds.count
If Len(ModuleObject.ProcOfLine(TheLine, AllKinds(i))) Then
If InStr(1, LaLigne, " Function ") Then
vbe_LineInfo = 3
ElseIf InStr(1, LaLigne, " Sub ") Then
vbe_LineInfo = 4
End If
Exit Function
End If
Next i
End Function
Function VBE_TPL_BuildRoutinesList(ModuleObject As VBIDE.CodeModule, TheLine As Long) As Variant
'Dresser la liste des procédures et fonctions
Dim F_LF As Boolean, F_F As Boolean, F_P As Boolean
Dim ProcKind As VBIDE.vbext_ProcKind
Dim VBA_LibraryFunctions() As Variant
Dim VBA_Procedures() As Variant
Dim VBA_Functions() As Variant
Dim RoutinesList As Variant
Dim ProcName As String
Dim LineNum As Long
Dim DimArray As Long
On Error Resume Next
ReDim Preserve VBA_Functions(0)
ReDim Preserve VBA_LibraryFunctions(0)
ReDim Preserve VBA_Procedures(0)
With ModuleObject
'la liste généré est à incomplete, 2 facteurs peut-être :
' - le compte de lignes de déclaration
' - regarder du côté de vbe_lineinfo
For LineNum = 1 To .CountOfLines
ProcName = .ProcOfLine(LineNum, ProcKind)
If ProcName <> "" Then
Select Case vbe_LineInfo(ModuleObject, LineNum)
Case VBALine_Function
F_F = True
If IsEmpty(VBA_Functions(0)) = False Then _
ReDim Preserve VBA_Functions(UBound(VBA_Functions) + 1)
VBA_Functions(UBound(VBA_Functions)) = "'" & vbTab & ProcName
Case VBALine_LibraryFunction
F_LF = True
If IsEmpty(VBA_LibraryFunctions(0)) = False Then _
ReDim Preserve VBA_LibraryFunctions(UBound(VBA_LibraryFunctions))
VBA_LibraryFunctions(UBound(VBA_LibraryFunctions)) = "'" & vbTab & ProcName
Case VBALine_Procedure
F_P = True
If IsEmpty(VBA_Procedures(0)) = False Then _
ReDim Preserve VBA_Procedures(UBound(VBA_Procedures))
VBA_Procedures(UBound(VBA_Procedures)) = "'" & vbTab & ProcName
End Select
End If
Next LineNum
End With
RoutinesList = IIf(F_LF = True, "' Library Functions : <<" & vbCr & Join(VBA_LibraryFunctions, vbCr) & vbCr & "' >>" & vbCr, "") _
& IIf(F_F = True, "' Functions : <<" & vbCr & Join(VBA_Functions, vbCr) & vbCr & "' >>" & vbCr, "") _
& IIf(F_P = True, "' Procedures : <<" & vbCr & Join(VBA_Procedures, vbCr) & vbCr & "' >>" & vbCr & "'", "")
If RoutinesList <> "" Then
ModuleObject.InsertLines TheLine, RoutinesList
End If
End Function
j'avais aussi créé cette fonction
Function vbe_IsRoutineDeclaration(ModuleObject As VBIDE.CodeModule, TheLine As Long) As Boolean
'Solution designed by STephane
Dim AllKinds As New Collection
AllKinds.Add vbext_pk_Get
AllKinds.Add vbext_pk_Set
AllKinds.Add vbext_pk_Let
AllKinds.Add vbext_pk_Proc
For i = 1 To AllKinds.count
If Len(ModuleObject.ProcOfLine(TheLine, AllKinds(i))) Then
vbe_IsRoutineDeclaration = True
Exit Function
End If
Next i
End Function
