J'ai cherché dans les forums et applications VB mais rien qui semblait correspondre à mon besoin.
Ma conf : Excel 2003
En ayant des fichiers JPG présent dans un dossier (genre C:/TOTO). Le fichier TOTO contenant par exemple 2 JPG nommés "coco1" et "coco2".
J'aimerai faire une macro qui copie les noms de fichier ("coco1" et "coco2") dans une feuille Excel et qui fasse les liens hypertexte automatiquement.
J'espère que ma description est assez claire.
Merci d'avance et merci à toute l'équipe.
Bon j'ai testé ton code et ca me met toujours le lien vers le dossier et non le fichier, j'ai fait quelque recherches sur le net et j'ai trouvé quelque chose similaire, je l'ai donc adapté en le mixant avec ton dernier code et voilà ce que ca donne :
dans un module
Sub ScanClasseurs()
Dim Dossier As Object, Fichier As Object
Dim chemin As String
Dim TabDossiers As Variant
Dim L As Long, D As Long
chemin = ChoisirDossier
If chemin = "" Then Exit Sub
Application.ScreenUpdating = False
L = 1
'Création du tableau des sous-dossiers existants
TabDossiers = lstDossiers(chemin, True)
For D = 1 To UBound(TabDossiers)
'Chemin du dossier (ou sous-dossier) à analyser
chemin = TabDossiers(D)
If Right(chemin, 1) <> "" Then chemin = chemin & ""
'Analyse du dossier (ou sous-dossier)
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
For Each Fichier In Dossier.Files
'Liste les fichiers
L = L + 1
'MAJ feuille résultats
With ThisWorkbook.ActiveSheet
.Hyperlinks.Add Anchor:=.Cells(L, 2), Address:=chemin & Fichier.Name, _
TextToDisplay:=Fichier.Name
End With
Next
Next D
'tri de la colonne B
Columns("B:B").Select
Range("A1:C65536").Sort Key1:=Range("B1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Private Function lstDossiers(chemin As String, Optional Debut As Boolean) As Variant
Dim Dossier As Object, SD As Object, D As Object
Static TabTemp() As String
If Debut Then
ReDim TabTemp(1 To 1)
TabTemp(1) = chemin
End If
Set Dossier = CreateObject("Scripting.FileSystemObject").GetFolder(chemin)
'examen du dossier courant
For Each D In Dossier.subfolders
ReDim Preserve TabTemp(1 To UBound(TabTemp) + 1)
TabTemp(UBound(TabTemp)) = D.Path
Next
'Traitement récursif des sous-dossiers (d'après un code de F.Sigonneau)
For Each SD In Dossier.subfolders
lstDossiers SD.Path
Next SD
lstDossiers = TabTemp()
Set Dossier = Nothing
End Function
Function ChoisirDossier()
Dim objShell, objFolder, chemin As String, SecuriteSlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisissez un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.Items.Item.Path
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoisirDossier = chemin
End Function
En tout cas merci d'avoir passé du temps sur mon sujet ;-)
Dans une UserForm:
1 button
1 TextBox nommé: Textcellule pour choisir la cellule où mettre le lien
1 TextBox nommé: Textname pour mettre le nom du lien
Dim Fichier As Variant
Private Sub CommandButton1_Click()
Fichier = Application.GetOpenFilename( _
"Fichiers Image (*.jpg;*.gif;*.png;*.tif;*.bmp),*.jpg;*.gif;*.png;*.tif;*.bmp")
If Fichier = False Then Exit Sub
Range(Textcellule).Select
Textcellule.Value = Textname
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=Fichier, TextToDisplay:=Textcellule.Value
End Sub
Merci pour ta réponse ;-), j'ai fait exactement ce que tu as dit mais ce n'est pas tout à fait ce que je souhaitais. En fait ton code permet de faire un lien hypertexte du dossier et non de chaque fichier.
J'aimerai qu'il me fasse indépendamment les liens vers tous les fichiers présents dans le dossier avec comme donnée d'entrée le chemin du dossier.
exemple le lien vers "toto1.jpg" puis "toto2.jpg" puis "toto3.jpg" sachant que la macro doit aussi récupérer les noms de chaque fichiers
et non le lien vers le dossier qui contient les fichiers toto1, toto2, toto3
Je t'ai fait un code qui te met un lien hypertexte sur tous les fichiers d'un dossier et sous-dossiers dans la colonne A, mais tu peux changer de colonne tout est expliqué.
Un UserForm
1 button
1 ChexkBox pour la sélection des sous-dossiers
Tu mets ceci dans un module:
Declare Function GetFileTitleA Lib "Comdlg32" _
(ByVal lpszFile As String, ByVal lpszTitle As String, _
ByVal cbBuf As Long) As Long
Dim I As Integer
Dim cheminfichier As String
Dim nom As String
Sub ListFiles()
'Quel répertoire?
Directory = ChoisirDossier
'Récupérez les fichiers
On Error Resume Next
With Application.FileSearch
.NewSearch
.LookIn = Directory
.Filename = "*.*" 'mettre l'extension si on le désire
If UserForm1.CheckBox1 = True Then
.SearchSubFolders = True 'avec sous-dossier
Else
.SearchSubFolders = False 'sans sous-dossier
End If
.Execute
' Donnez les informations du fichier
For I = 1 To .FoundFiles.Count
cheminfichier = .FoundFiles(I)
nom_fichier
Range("A" & I).Select 'sélectionne la colonne, on peut changer
ActiveCell.FormulaR1C1 = nom & I
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:=cheminfichier, SubAddress:= _
cheminfichier & I & "!A1", TextToDisplay:=nom & I
r = r + 1
Next I
End With
End Sub
Sub nom_fichier()
s$ = cheminfichier
If s = "" Then Exit Sub
nom = NomFich(s)
End Sub
Function NomFich(chemin As String) As String
Dim cbBuf As Long
cbBuf = GetFileTitleA(chemin, vbNullString, 0)
NomFich = Space$(cbBuf)
GetFileTitleA chemin, NomFich, cbBuf
End Function
Function ChoisirDossier()
Dim objShell, objFolder, chemin As String, SecuriteSlash
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.BrowseForFolder(&H0&, "Choisissez un répertoire", &H1&)
On Error Resume Next
chemin = objFolder.Items.Item.path
SecuriteSlash = InStr(objFolder.Title, ":")
If SecuriteSlash > 0 Then
chemin = Mid(objFolder.Title, SecuriteSlash - 1, 2) & ""
End If
ChoisirDossier = chemin
End Function
et dans le button de ton UserForm pour lancer la macro:
Private Sub CommandButton1_Click()
ListFiles
End Sub
n'oublies pas de mettre ton checkBox pour les sous-dossiers
