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
| Function Liste_Procedures_Fonctions_VBA(pathbase As String) As Boolean
Dim strSQL As String
Dim Accmodule As Module
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim Cible As String
Dim oAccess As New Access.Application
Dim oDb As DAO.Database
On Error GoTo fin
With oAccess
.Visible = False
.OpenCurrentDatabase (pathbase)
Set oDb = .CurrentDb
End With
pCreateTable
For i = 1 To oAccess.VBE.VBProjects(1).VBComponents.Count
With oAccess.VBE.VBProjects(1).VBComponents.item(i).CodeModule
' pour le remplacement d'une ligne entière
For k = 1 To .CountOfLines
Cible = .Lines(k, 1)
'Debug.Print Cible
If Left(Cible, 1) <> "'" Then
If InStr(1, Cible, "Function ") > 0 Then
CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM,RETURN) VALUES ('" & pathbase & "','Function','" & RecupererTexteEntreBornes(Cible, "Function ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "','" & RecupererTexteEntreBornes(Cible, ") As ", "") & "')"
End If
If InStr(1, Cible, "Sub ") > 0 Then
CurrentDb.Execute "INSERT INTO T_LISTE_PROCEDURES (DB_PATH,FUNCTION_OR_SUB,NM_FUNCTION_OR_SUB,PARAM) VALUES ('" & pathbase & "','Sub','" & RecupererTexteEntreBornes(Cible, "Sub ", "(") & "','" & RecupererTexteEntreBornes(Cible, "(", ")") & "')"
End If
End If
Next k
End With
Next i
CurrentDb.Execute "UPDATE T_LISTE_PROCEDURES SET PARAM = '' WHERE Left(PARAM,1)=')'"
oDb.Close
oAccess.DoCmd.Close , , acSaveYes
Set oAccess = Nothing
Set oDb = Nothing
Liste_Procedures_Fonctions_VBA = True
Exit Function
fin:
Liste_Procedures_Fonctions_VBA = False
Resume Next
End Function
'Fonction utilisée pour récuperer un texte compris entre deux autres
'exemple : RecupererTexteEntreBornes("<html><body>Pioupi</body></html>","<body>","</body>")
'retournera Pioupi
Function RecupererTexteEntreBornes(texte As String, textedebut As String, textefin As String) As String
Dim result As String
Dim debut As Integer
Dim fin As Integer
debut = InStr(1, texte, textedebut)
fin = InStr(debut + Len(textedebut), texte, textefin)
result = ""
If debut > 0 Then
If fin > debut + Len(textedebut) Then
result = Mid(texte, debut + Len(textedebut), fin - debut - Len(textedebut))
Else
result = Right(texte, Len(texte) - debut - Len(textedebut) + 1)
End If
End If
RecupererTexteEntreBornes = result
End Function
Public Sub pCreateTable()
Dim Db As Database
Dim tblTable As TableDef
Dim fldTemp As Field
Set Db = CurrentDb()
If DoesTableExist("T_LISTE_PROCEDURES") Then Db.Execute ("DROP TABLE T_LISTE_PROCEDURES")
' Description et création des attributs de la table
Set tblTable = Db.CreateTableDef("T_LISTE_PROCEDURES")
With tblTable
Set fldTemp = .CreateField("DB_PATH", dbText)
fldTemp.Required = False
fldTemp.AllowZeroLength = True
.Fields.Append fldTemp
Set fldTemp = .CreateField("FUNCTION_OR_SUB", dbText)
fldTemp.Required = False
fldTemp.AllowZeroLength = True
.Fields.Append fldTemp
Set fldTemp = .CreateField("NM_FUNCTION_OR_SUB", dbText)
fldTemp.Required = False
fldTemp.AllowZeroLength = True
.Fields.Append fldTemp
Set fldTemp = .CreateField("PARAM", dbText)
fldTemp.Required = False
fldTemp.AllowZeroLength = True
.Fields.Append fldTemp
Set fldTemp = .CreateField("RETURN", dbText)
fldTemp.Required = False
fldTemp.AllowZeroLength = True
.Fields.Append fldTemp
End With
Db.TableDefs.Append tblTable
End Sub
'*****************************
'fonction de test d'existence d'une table par les propriétés VBA
'input = nom de la table
'output = booleen
'*****************************
Function DoesTableExist(ByVal NomTable As String) As Boolean
Dim str As String
On Error GoTo NoTable
str = CurrentDb.TableDefs(NomTable).Name
DoesTableExist = True
Exit Function
NoTable:
Select Case err.Number
Case 3265
DoesTableExist = False
End Select
End Function |
Partager