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
|
Sub liaison()
ListerFichiers chemin(), True 'false s'il ne faut pas prendre en compte les sous-dossiers
End Sub
'Fonction pour récupérer le chemin du dossier
Function chemin() As String
chemin = Application.ThisWorkbook.Path
End Function
'-------------------------------------------
Sub ListerFichiers(chemin As String, bIncludeSubfolders As Boolean)
' necessite d'activer la reference Microsoft Scripting RunTime
Static FSO As FileSystemObject
Dim oSourceFolder As Scripting.Folder
Dim oSubFolder As Scripting.Folder
Dim oFile As Scripting.File
Dim nom As String
Dim first As String
Dim lien(1) As String
Dim oldlink As String
Set FSO = CreateObject("Scripting.FileSystemObject")
Set oSourceFolder = FSO.GetFolder(chemin)
Set wb(1) = ThisWorkbook 'WB(1) = VT
For Each oFile In oSourceFolder.Files 'pour chaque fichier dans le dossier
If Not oFile.Name = wb(1).Name Then 'si ce n'est pas le fichier de VT
nom = oFile.Name 'récupere le nom du fichier
first = Mid(nom, 1, 1) 'récupere le 1er caratere du nom
If Not first = "~" Then
On Error GoTo Erreur
Workbooks.Open (chemin & "\" & nom) 'ouvre le fichier assemblage
Set wb(2) = Application.ActiveWorkbook 'Wb(2) = fichier assemblage ouvert
lien(1) = ActiveWorkbook.LinkSources(xlExcelLinks)
If Not IsEmpty(lien) Then
oldlink = lien(1)
End If
'procédure pour le changement de liaison ---- A DEFINIR ---
'wb(2).Close (True)
End If
End If
Next oFile
If bIncludeSubfolders Then
For Each oSubFolder In oSourceFolder.SubFolders
ListerFichiers oSubFolder.Path, True
Next oSubFolder
End If
Erreur:
Select Case Err.Number
Case 1004
MsgBox "Enregistrez d'abord " & oFile.Name
Exit Sub
Case Else
MsgBox (Err.Number)
End Select
End Sub |
Partager