Extraire le chemin d'acces d'un fichier
Résolu
Nuage75
Messages postés
22
Date d'inscription
Statut
Membre
Dernière intervention
-
Nuage75 Messages postés 22 Date d'inscription Statut Membre Dernière intervention -
Nuage75 Messages postés 22 Date d'inscription Statut Membre Dernière intervention -
Bonjour,
Je dispose d'un dossier contenant plusieurs sous dossiers.
Un code me permet d'extraire le nom des fichiers et de crée un lien d'accès. J'aimerais y ajouter le chemin d'accès complet.
La macro est :
Public ListeDoss() As String
Sub ChercheDoss(Chemin1 As String)
Dim Ligne As Long, Nom As String
Ligne = Range("A65536").End(xlUp).Row + 1
On Error GoTo Err1
Nom = Dir(Chemin1 & "\*" & Range("Texte").Value & "*" & Range("Ext").Value)
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 2), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
Do
Ligne = Range("A65536").End(xlUp).Row + 1
Nom = Dir
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 2), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
End If
Loop Until Nom = ""
End If
Err1:
End Sub
Sub ChercheTout()
Dim Chemin As String, i As Long
Range("A7:C65536").Clear
Chemin = Range("Doss").Value
LanceListe Chemin
For i = 1 To UBound(ListeDoss)
ChercheDoss ListeDoss(i)
Next i
End Sub
Sub ListeArborescence(Dossier As String)
Dim fs, sousdoss
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each sousdoss In fs.getfolder(Dossier).subfolders
ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
ListeDoss(UBound(ListeDoss)) = sousdoss.Path
ListeArborescence sousdoss.Path
Next sousdoss
On Error GoTo 0
Set fs = Nothing
End Sub
Sub LanceListe(Dossier As String)
ReDim ListeDoss(1 To 1)
ListeDoss(1) = Dossier
ListeArborescence Dossier
End Sub
Pouvez vous m'aider ?
Merci d'avance
Je dispose d'un dossier contenant plusieurs sous dossiers.
Un code me permet d'extraire le nom des fichiers et de crée un lien d'accès. J'aimerais y ajouter le chemin d'accès complet.
La macro est :
Public ListeDoss() As String
Sub ChercheDoss(Chemin1 As String)
Dim Ligne As Long, Nom As String
Ligne = Range("A65536").End(xlUp).Row + 1
On Error GoTo Err1
Nom = Dir(Chemin1 & "\*" & Range("Texte").Value & "*" & Range("Ext").Value)
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 2), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
Do
Ligne = Range("A65536").End(xlUp).Row + 1
Nom = Dir
If Nom <> "" Then
Cells(Ligne, 1).Value = Nom
ActiveSheet.Hyperlinks.Add Anchor:=ActiveSheet.Cells(Ligne, 2), Address:=Chemin1 & "\" & Nom, TextToDisplay:=Nom
End If
Loop Until Nom = ""
End If
Err1:
End Sub
Sub ChercheTout()
Dim Chemin As String, i As Long
Range("A7:C65536").Clear
Chemin = Range("Doss").Value
LanceListe Chemin
For i = 1 To UBound(ListeDoss)
ChercheDoss ListeDoss(i)
Next i
End Sub
Sub ListeArborescence(Dossier As String)
Dim fs, sousdoss
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
For Each sousdoss In fs.getfolder(Dossier).subfolders
ReDim Preserve ListeDoss(1 To UBound(ListeDoss) + 1)
ListeDoss(UBound(ListeDoss)) = sousdoss.Path
ListeArborescence sousdoss.Path
Next sousdoss
On Error GoTo 0
Set fs = Nothing
End Sub
Sub LanceListe(Dossier As String)
ReDim ListeDoss(1 To 1)
ListeDoss(1) = Dossier
ListeArborescence Dossier
End Sub
Pouvez vous m'aider ?
Merci d'avance
A voir également:
- Récupérer le chemin d'un fichier vba
- Fichier bin - Guide
- Comment réduire la taille d'un fichier - Guide
- Comment ouvrir un fichier epub ? - Guide
- Récupérer au terminal de fret - Forum Consommation & Internet
- Fichier rar - Guide
Merci de me venir en aide, je n'arrive pas du tout à l'intégrer, j'aimerais que dans la première colonne s'affiche le chemin d'accès complet puis le nom du fichier et les liens d'accès dans la colonne C.
J'ai déjà passé 3heures dessus et n'y arrive pas, je suis un débutant dans le domaine.