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 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226
| Option Explicit
Dim i As Integer, k As Integer
Dim tabFichiers() As Variant
Sub ImporterTousLesModules()
Dim objShell As Object, objFolder As Object, objFolderItem As Object
Dim objFSO As Object, objSubFolder As Object, objFile As Object
Dim CheminRep As String
Dim tabDossiers As Variant
Dim tabextensions As Variant
tabDossiers = Array()
tabextensions = Array("bas", "frm", "cls")
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisir un répertoire", &H1&, ThisWorkbook.Path)
'si Annuler , fin de Sub
If objFolder Is Nothing Then Exit Sub
Set objFolderItem = objFolder.Self
CheminRep = objFolderItem.Path
'Insertion du chemin dans le tableau
ReDim Preserve tabDossiers(UBound(tabDossiers) + 1)
tabDossiers(UBound(tabDossiers)) = CheminRep
'Recherche des sous répertoires
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Ajout des chemins des sous répertoires au tableau
For Each objSubFolder In objFSO.GetFolder(CheminRep).SubFolders
ReDim Preserve tabDossiers(UBound(tabDossiers) + 1)
tabDossiers(UBound(tabDossiers)) = objSubFolder.Path
Next
Dim Tag2 As String
'Recherche des fichiers
k = 0
For i = 0 To UBound(tabDossiers)
For Each objFile In objFSO.GetFolder(tabDossiers(i)).Files
' If Not Right(objFile.Name, 3) = "frx" Then
If Not IsError(Application.Match(Extension(objFile.Name, True), tabextensions, 0)) Then 'ajout
ReDim Preserve tabFichiers(2, k)
'Ajout du nom au tableau
tabFichiers(0, k) = objFile.Name
'Ajout du chemin au tableau
tabFichiers(1, k) = objFile.Path
Select Case Extension(objFile.Name, True)
Case "bas": Tag2 = "Module standard"
Case "cls": Tag2 = "Module de classe"
Case "frm": Tag2 = "User Form"
End Select
tabFichiers(2, k) = IIf(InStr(1, objFile.Path, "Modules de feuille") > 0, "Module de feuille", Tag2)
k = k + 1
End If
Next objFile
Next i
Set objShell = Nothing
Set objFolder = Nothing
Set objFolderItem = Nothing
Set objFSO = Nothing
Set objSubFolder = Nothing
'Affichage des Modules dans un USF
NewUserForm '"Modules"
End Sub
Function Extension(Fichier As String, Optional SansPt As Boolean = False) As String
Extension = Mid(Fichier, InStrRev(Fichier, ".") + Abs(SansPt))
End Function
Sub NewUserForm()
Dim ufCaption As String
Dim ub As Integer
Dim j As Integer
Dim Col As Integer
Dim ufTemp As Object
Dim newBtn As Object
Dim LargMax As Integer
Dim HauteurUSF As Integer
Dim LargUSF As Integer
Dim DerLiCode As Integer
Dim Code As String
ufCaption = "Choix des modules à importer"
ub = k - 1
'Application.VBE.MainWindow.Visible = False
j = 0: Col = 15
'Création du UserForm
Set ufTemp = ThisWorkbook.VBProject.VBComponents.Add(3) 'vbext_ct_MSForm
'Création des cases à cocher, 10 par "colonnes"
For i = 0 To ub
Set newBtn = ufTemp.Designer.Controls.Add("forms.checkbox.1")
With newBtn
.Caption = tabFichiers(0, i)
' si changement de dizaine, nouvelle colonne
If i Mod 10 = 0 Then Col = Col + LargMax: LargMax = 0: j = 0
.Left = Col
.Top = 10 + 20 * j
.WordWrap = False
.AutoSize = True
If .Width > LargMax Then LargMax = .Width
.Tag = tabFichiers(1, i)
.ControlTipText = tabFichiers(2, i)
End With
j = j + 1
Next i
'Création du bouton OK
Set newBtn = ufTemp.Designer.Controls.Add("forms.CommandButton.1", "BtnOK")
With newBtn
.Caption = "OK": .Accelerator = "O"
.Left = IIf(Col + LargMax - .Width > 95, Col + LargMax - .Width, 95)
.Top = IIf(i > 9, 220, (i + 1) * 20)
.Default = True
HauteurUSF = .Top + .Height + 60
LargUSF = .Left + .Width + 20
End With
'Création du bouton Annuler
Set newBtn = ufTemp.Designer.Controls.Add("forms.CommandButton.1", "BtnAnnuler")
With newBtn
.Caption = "Annuler": .Accelerator = "A"
.Left = 15: .Top = IIf(i > 9, 220, (i + 1) * 20)
End With
'Case Cocher tout
Set newBtn = ufTemp.Designer.Controls.Add("forms.checkbox.1", "ToutOuRien")
With newBtn
.Caption = "Cocher tout": .Accelerator = "C"
.Left = 15: .Top = HauteurUSF - 45: .AutoSize = True
End With
'Dimensions du USF
With ufTemp
' .Properties("Name") = "ufTemp"
.Properties("Caption") = ufCaption
.Properties("Width") = LargUSF
.Properties("Height") = HauteurUSF
End With
'Ajout de code au bouton "BtnOK"
Code = Code & "Sub BtnOK_Click()" & vbLf
Code = Code & "Unload Me" & vbLf
Code = Code & "Dim i As Integer" & vbLf
Code = Code & "Dim Chaine As String, NomSansExt As String" & vbLf
Code = Code & "" & vbLf
Code = Code & "For i = 1 To " & ub + 1 & vbLf
Code = Code & " If Controls(""CheckBox"" & i) Then" & vbLf
Code = Code & " If Controls(""CheckBox"" & i).ControlTipText = ""Module de feuille"" Then" & vbLf
Code = Code & " NomSansExt = Mid(Controls(""CheckBox"" & i).Caption, 1, InStr(1, Controls(""CheckBox"" & i).Caption, ""."") - 1)" & vbLf
Code = Code & " EcrireCodeFeuille Controls(""CheckBox"" & i).Tag, NomSansExt" & vbLf
Code = Code & " Else" & vbLf
Code = Code & " RemplacerModule NomSansExt, Controls(""CheckBox"" & i).Tag" & vbLf
Code = Code & " End If" & vbLf
Code = Code & " End If" & vbLf
Code = Code & "Next i" & vbLf
Code = Code & "End Sub" & vbLf
'Ajout du code de la case à cocher "Cocher tout"
Code = Code & "Private Sub ToutOuRien_Click()" & vbLf
Code = Code & "Dim Ctrl As Control" & vbLf
Code = Code & "For Each Ctrl In Me.Controls" & vbLf
Code = Code & "If TypeName(Ctrl) = ""CheckBox"" Then Ctrl.Value = ToutOuRien.Value" & vbLf
Code = Code & "Next Ctrl" & vbLf
Code = Code & "End Sub" & vbLf
'Ajout de code au bouton BtnAnnuler
Code = Code & "Sub BtnAnnuler_Click()" & vbLf
Code = Code & "Unload Me" & vbLf
Code = Code & "End Sub" & vbLf
'Ajout de code au bouton OK
With ufTemp.CodeModule
DerLiCode = .CountOfLines
.InsertLines DerLiCode + 1, Code
End With
'Affichage du USF
VBA.UserForms.Add(ufTemp.Name).Show
'Suppression du USF
ThisWorkbook.VBProject.VBComponents.Remove ufTemp
'Application.VBE.CommandBars.FindControl(ID:=106).Execute
End Sub
Sub EcrireCodeFeuille(NomDeFichier, monModule)
Dim NoFichier As Integer
Dim LongueurFichier As Long
Dim LeCode As String
NoFichier = FreeFile()
'Ouvre le fichier en mode lecture.
Open NomDeFichier For Input As #NoFichier
LongueurFichier = FileLen(NomDeFichier)
LeCode = Input(LongueurFichier, NoFichier)
Close NoFichier
With ActiveWorkbook.VBProject.VBComponents(monModule).CodeModule
'Suppression du code existant
.DeleteLines 1, .CountOfLines
'Insertion du code
.InsertLines 1, LeCode
End With
End Sub
Sub RemplacerModule(Ancien, Nouveau)
With ActiveWorkbook.VBProject
'Suppression du module si existant
If ModuleExists(CStr(Ancien)) Then _
.VBComponents.Remove .VBComponents(Ancien)
'Importation
.VBComponents.Import Nouveau
End With
End Sub
Function ModuleExists(VBCompName As String) As Boolean
'Code de Chip Pearson
On Error Resume Next
ModuleExists = CBool(Len(ActiveWorkbook.VBProject.VBComponents(VBCompName).Name))
End Function |
Partager