Posez votre question Signaler

Lien hypertexte automatique [Résolu]

Messages postés
6
Date d'inscription
lundi 2 août 2010
Statut
Membre
Dernière intervention
20 décembre 2010
 - - Dernière réponse : ginestetromain
Messages postés
6
Date d'inscription
lundi 2 août 2010
Statut
Membre
Dernière intervention
20 décembre 2010
 - 15 déc. 2010 à 20:14
VB.NET Posez votre question Signaler
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.
Afficher la suite 

4 réponses

Meilleure réponse
Signaler Commenter la réponse de ginestetromain
Messages postés
6
Date d'inscription
lundi 2 août 2010
Statut
Membre
Dernière intervention
20 décembre 2010
3
Merci
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,

Dire « Merci » 3

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

Codes Sources 198 internautes nous ont dit merci ce mois-ci

Commenter la réponse de ginestetromain
Signaler Commenter la réponse de cs_Le Pivert
Messages postés
6274
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
16 octobre 2019
 87
0
Merci
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
Commenter la réponse de cs_Le Pivert
Signaler Commenter la réponse de ginestetromain
Messages postés
6
Date d'inscription
lundi 2 août 2010
Statut
Membre
Dernière intervention
20 décembre 2010
0
Merci
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.
Commenter la réponse de ginestetromain
Signaler Commenter la réponse de cs_Le Pivert
Messages postés
6274
Date d'inscription
jeudi 13 septembre 2007
Statut
Contributeur
Dernière intervention
16 octobre 2019
 87
0
Merci
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
Commenter la réponse de cs_Le Pivert
Répondre Posez votre question