Macro pour lien hypertexte liste de documents
S
Bonjour tout le monde,
Je cherche à faire l'action suivante avec une macro sans y parvenir.
J'ai une feuille Excel avec une colonne contenant des références de pièces.
J'ai un dossier contenant plein de sous-dossiers avec différents types de fichiers à l'intérieur de chaque sous-dossier. Les sous-dossiers comportent dans leur noms au moins le numéro des références spécifié dans la feuille Excel (il se peut qu'il y ai d'autres caractères dans le nom des dossiers).
Dans chacun des sous dossiers se trouver des fichiers .pdf (plans et nomenclatures de pièces) et des .tif.
J'aimerais que lorsque que je clique dans mon fichier Excel sur une référence (cellule ou lien hypertexte) cela créé une liste dans une nouvelle Feuille Excel de l'ensemble des fichiers (.pdf et .tif) se trouvant dans le sous-dossier qui contient le nom de cette référence, en effectuant une recherche de ce sous-dossier dans mon dossier principal. J'aimerais que cette liste de fichier pointe avec des liens hypertextes vers les fichiers (.pdf et .tif) pour pouvoir les ouvrir rapidement.
Si possible j'aimerais aussi que la feuille qui contient cette liste s'auto supprime dès que l'on change de worksheet/feuille, afin qu'il n'y ai pas une infinité de feuille de créé à chaque fois que l'on clique sur une réf.
Je ne sais pas si c'est 100% clair ?
J'ai trouvé un code qui fait la moitier du boulot, mais je ne sais comment coder le reste... Le code ouvre une fenetre pour selectionner le répertoire. Je préférerais que le répertoire du dossier principal soit déjà dans le code.
http://www.vbaexpress.com/kb/getarticle.php?kb_id=232
Option Compare Text
Option Explicit
Function Excludes(Ext As String) As Boolean
'Function purpose: To exclude listed file extensions from hyperlink listing
Dim X, NumPos As Long
'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip")
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0
End Function
Sub HyperlinkFileList()
'Macro purpose: To create a hyperlinked list of all files in a user
'specified directory, including file size and date last modified
'NOTE: The 'TextToDisplay' property (of the Hyperlink object) was added
'in Excel 2000. This code tests the Excel version and does not use the
'Texttodisplay property if using XL 97.
Dim fso As Object, _
ShellApp As Object, _
File As Object, _
SubFolder As Object, _
Directory As String, _
Problem As Boolean, _
ExcelVer As Integer
'Turn off screen flashing
Application.ScreenUpdating = False
'Create objects to get a listing of all files in the directory
Set fso = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
Set ShellApp = CreateObject("Shell.Application"). _
Browseforfolder(0, "Please choose a folder", 0, "c:\\")
On Error Resume Next
'Evaluate if directory is valid
Directory = ShellApp.self.path
Set SubFolder = fso.GetFolder(Directory).Files
If Err.Number <> 0 Then
If MsgBox("You did not choose a valid directory!" & vbCrLf & _
"Would you like to try again?", vbYesNoCancel, _
"Directory Required") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
'Set up the headers on the worksheet
With ActiveSheet
With .Range("A1")
.Value = "Listing of all files in:"
.ColumnWidth = 40
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory, _
TextToDisplay:=Directory
Else 'Using XL97
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory
End If
End With
With .Range("A2")
.Value = "File Name"
.Interior.ColorIndex = 15
With .Offset(0, 1)
.ColumnWidth = 15
.Value = "Date Modified"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 2)
.ColumnWidth = 15
.Value = "File Size (Kb)"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list
For Each File In SubFolder
If Not Excludes(Right(File.path, 3)) = True Then
With ActiveSheet
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.path, _
TextToDisplay:=File.Name
Else 'Using XL97
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.path
End If
'Add date last modified, and size in KB
With .Range("A65536").End(xlUp)
.Offset(0, 1) = File.datelastModified
With .Offset(0, 2)
.Value = WorksheetFunction.Round(File.Size / 1024, 1)
.NumberFormat = "#,##0.0"
End With
End With
End With
End If
Next
End Sub Est-ce que quelqu'un pourrait m'aider.
Merci pour votre attention
S
Bonjour à tous,
Personne pour me donner un coup de main ? Je galère vraiment pour avoir une macro qui fonctionne...
Merci pour votre attention
S
Ci-joint ce que j'utilise
Option Compare Text
Option Explicit
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If InRange(ActiveCell, Range("K11646:K17457")) Then
Dim FSO As Object, _
ShellApp As Object, _
File As Object, _
SubFolder As Object, _
Directory As String, _
SubDir As String, _
Problem As Boolean, _
ws As Worksheet, _
ExcelVer As Integer
'Turn off screen flashing
Application.ScreenUpdating = False
'Create objects to get a listing of all files in the directory
Set FSO = CreateObject("Scripting.FileSystemObject")
'Prompt user to select a directory
Do
Problem = False
'Set ShellApp = CreateObject("Shell.Application"). _
'Browseforfolder(0, "Please choose a folder", 0, "c:\\")
On Error Resume Next
'Evaluate if directory is valid
'#################################################################'
'####REMPLACER LE REPERTOIRE OU SE TROUVE LES PLANS SI BESOIN#####'
'#################################################################'
Directory = "M:\......\PLANS ET NOMENCLATURES"
'Directory = ShellApp.self.Path
SubDir = Recurse(Directory)
Set SubFolder = FSO.GetFolder(SubDir).Files
If Err.Number <> 0 Then
If MsgBox("You did not choose a valid directory!" & vbCrLf & _
"Would you like to try again?", vbYesNoCancel, _
"Directory Required") <> vbYes Then Exit Sub
Problem = True
End If
On Error GoTo 0
Loop Until Problem = False
'Set up the headers on the worksheet
Set ws = ThisWorkbook.Sheets.Add(Before:= _
ThisWorkbook.ActiveSheet)
ws.Name = "Liste Outils Coupants"
With ActiveSheet
With .Range("A1")
.Value = "Listing of all files in:"
.ColumnWidth = 40
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory, _
TextToDisplay:=Directory
Else 'Using XL97
.Parent.Hyperlinks.Add _
Anchor:=.Offset(0, 1), _
Address:=Directory
End If
End With
With .Range("A2")
.Value = "File Name"
.Interior.ColorIndex = 15
With .Offset(0, 1)
.ColumnWidth = 15
.Value = "Date Modified"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
With .Offset(0, 2)
.ColumnWidth = 15
.Value = "File Size (Kb)"
.Interior.ColorIndex = 15
.HorizontalAlignment = xlCenter
End With
End With
End With
'Adds each file, details and hyperlinks to the list
For Each File In SubFolder
If Not Excludes(Right(File.Path, 3)) = True Then
With ActiveSheet
'If Excel 2000 or greater, add hyperlink with file name
'displayed. If earlier, add hyperlink with full path displayed
If Val(Application.Version) > 8 Then 'Using XL2000+
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path, _
TextToDisplay:=File.Name
Else 'Using XL97
.Hyperlinks.Add _
Anchor:=ActiveSheet.Range("A65536").End(xlUp).Offset(1, 0), _
Address:=File.Path
End If
'Add date last modified, and size in KB
With .Range("A65536").End(xlUp)
.Offset(0, 1) = File.datelastModified
With .Offset(0, 2)
.Value = WorksheetFunction.Round(File.Size / 1024, 1)
.NumberFormat = "#,##0.0"
End With
End With
End With
End If
Next
Else
' code to handle that the active cell is not within the right range
MsgBox "Active Cell NOT In Range!"
End If
'BUTTON
Dim btn As Button
Application.ScreenUpdating = False
ActiveSheet.Buttons.Delete
Dim t As Range
Set t = ActiveSheet.Cells(5, 5)
Set btn = ActiveSheet.Buttons.Add(t.Left, t.Top, t.Width, t.Height)
With btn
.OnAction = "ClickTheButton"
.Caption = "FERMER"
.Name = "FERMER"
End With
Application.ScreenUpdating = True
End Sub
Function Excludes(Ext As String) As Boolean
'Function purpose: To exclude listed file extensions from hyperlink listing
Dim X, NumPos As Long
'Enter/adjust file extensions to EXCLUDE from listing here:
X = Array("exe", "bat", "dll", "zip")
On Error Resume Next
NumPos = Application.WorksheetFunction.Match(Ext, X, 0)
If NumPos > 0 Then Excludes = True
On Error GoTo 0
End Function
Function InRange(Range1 As Range, Range2 As Range) As Boolean
' returns True if Range1 is within Range2
InRange = Not (Application.Intersect(Range1, Range2) Is Nothing)
End Function
Function Recurse(sPath As String) As String
Dim FSO2 As New FileSystemObject
Dim myFolder As Folder
Dim mySubFolder As Folder
Dim myFile As File
Dim pos As Integer
Set myFolder = FSO2.GetFolder(sPath)
For Each mySubFolder In myFolder.SubFolders
pos = InStr(mySubFolder.Name, ActiveCell.Value)
'For Each myFile In mySubFolder.Files
If pos <> 0 Then
Recurse = mySubFolder.Path
Exit For
End If
'Next
Recurse = Recurse(mySubFolder.Path)
Next
End Function