Lien hypertexte automatiqueRésolu

Question

Bonjour,

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.

ginestetromain · Accepted Answer

Salut,

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 ;-)

A bientot,

cs_Le Pivert · Answer

Bonjour,
Je te propose ceci:

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



@+ Le Pivert

ginestetromain · Answer

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

J'espère que c'est plus clair...

Merci pour votre aide.

cs_Le Pivert · Answer

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

@+ Le Pivert

Lien hypertexte automatique

4 réponses

Votre réponse

Discussions similaires