XL 2013 VBA Rechercher fichier et création hyperlien de son chemin

[titymax]

Bonjour à tous,

Ce que je cherche à faire est assez simple dans l'absolu mais je n'ai rien trouvé d'approchant sur les différents forums.

Description :

1 - J'ai une valeur X dans une cellule qui est aussi une partie du nom d'un fichier PDF se trouvant qque part sur un serveur (je connais le début du chemin c'est tout).
2 - Je souhaite lancer une recherche de ce fichier PDF contenant dans son nom la valeur X (c'est une valeur numérique à 10 chiffres).
3 - Une fois le fichier trouvé, je veux ajouter en hyperlien son chemin à la cellule contenant la valeur X.

Voilà, simple non...lool

Merci d'avance et bonne journée à tous.

 

[xUpsilon]

Bonjour,

Simple proposition à adapter à ta situation pour créer un lien Hypertexte vers un fichier du nom de ce qu'il y a d'écrit dans ta cellule (avec le nom du fichier en B1, le lien hypertexte en A1, et à spécifier dans la lien de code tous les différents points que j'ai écrit en français.

Nom = Range("B1")
Range("A1").Hyperlinks.Add Anchor:=Selection, Address:=Chemin & Nom, SubAddress:="'" & FeuilleDestination & "'" & "!" & AdresseDestination, TextToDisplay:=TexteLien

Bonne continuation

 

[titymax]

Bonjour et merci xUpsilon,

Si j'ai bien compris il faut indiquer dans ton code le chemin pour aller chercher le fichier, mais justement ce dernier n'est pas connu puisque je souhaite le rechercher...
Peux tu stp m'éclairer un peu plus quant à ton code ?

Merci

 

[xUpsilon]

Ah oula si tu connais pas le chemin je crois que ça va etre trèès compliqué d'ouvrir le fichier haha ... Ce que tu peux faire à la limite c'est ouvrir l'explorateur de fichier, sélectionner le fichier et récupérer son chemin éventuellement.
Ma proposition permettait simplement d'avoir dans une cellule le nom du fichier et de stocker dans le code le chemin du dossier. Ainsi, tu n'as qu'à écrire dans telle ou telle cellule le nom du fichier et le lien HyperTexte se mettra à jour automatiquement vers le fichier souhaité. Mais pour cela il faudrait que tu renseignes le chemin dans le code et que tu récupères le nom du fichier dans une cellule.

Bonne continuation

 

[titymax]

OK, donc si je comprends bien, il n'est pas possible de rechercher via VBA un fichier donné sur un serveur ou tout autre support... comme quoi il y a des limites à tout.

Quoi qu'il en soit je te remercie de ton aide.

 

[xUpsilon]

Rechercher sans connaitre le nom complet ni ouvrir l'explorateur non je ne pense pas.

Bonne continuation

 

[Dranreb]

Bonjour.
Il y a quand même des recherches possibles sans l'explorateur avec l'objet FileSystemObject de la bibliothèque Scripting (référence Microsoft Scrpting Runtime, fichier scrrun.dll).

 

[xUpsilon]

Ca dépasse mon domaine de compétences là, navré

Bonne continuation

 

[titymax]

Bonjour Dranreb,

Comment décliner les recherches que tu évoques par rapport à mon problème ?

Merci d'avance pour ta réponse...

 

[Dranreb]

Attend, je vais écrire une Function Réffic(ByVal Racine As String, ByVal MasqueNomFic As String) As String

 

[Dranreb]

Option Explicit
Sub Test()
   MsgBox RéfFic("C:\Users\Luck", "DéS*.Png")
   End Sub
Function RéfFic(ByVal Racine As String, ByVal MasqueNomFic As String) As String
   Dim FSO As New FileSystemObject, Dossier As Folder, Fichier As File
   On Error Resume Next
   Set Dossier = FSO.GetFolder(Racine)
   If Err Then Réffic = "(" & Racine & " ?)": Exit Function
   Set Fichier = FicChrch(Dossier, UCase$(MasqueNomFic))
   If Fichier Is Nothing Then RéfFic = "(" & Racine & "," & MasqueNomFic & " ?)": Exit Function
   RéfFic = Fichier.Path
   End Function
Private Function FicChrch(ByVal Doss As Folder, ByVal Masque As String) As File
   On Error Resume Next
   For Each FicChrch In Doss.Files
      If UCase$(FicChrch.Name) Like Masque Then Exit Function
      Next FicChrch
   For Each Doss In Doss.SubFolders
      Set FicChrch = FicChrch(Doss, Masque)
      If Not FicChrch Is Nothing Then Exit Function
      Next Doss
   End Function

Ne pas oublier de cocher la référence Micrisoft Scripting Runtime (Elle est très portable, ça ne vaut vraiment pas le coup de se priver des liaisons anticipées. Je la coche systématiquement dans tous mes projets)

 

[titymax]

Je me sens tout petit petit là, c'est du costaud ce code pour un quasi novice comme moi en tous les cas...

A quel niveau dois-je placer ce code ? que signifie cette coche "référence Micrisoft Scripting Runtime ", où se trouve t'elle ?

Quel est le paramètre qui contient ma valeur X de départ ?

Désolé d'avoir autant de questions, mais là c'est du lourd pour moi.

Merci encore

 

[Dranreb]

Alt+OR, chercher dans la liste Microsoft Scripting Runtime et la cocher.
Le 1er paramètre est la référence du dossier racine, la seconde le nom de fichier avec des jockers '*' pour les parties variables.
Prendre RéfFic("\\CeQuIlFautIci\CeQuIlFautLà", "*" & X & "*.pdf") comme paramètre Address de la méthode Add de la collection Hyperlinks.

 

[Dranreb]

Si l'arborescence et celui de ses niveaux où se trouve le fichier sont un peu mieux connus, on peut l'écrire comme ça :

Option Explicit
Sub Test()
   MsgBox RéfFic("C:\Users\Luck", "Pic*", "DéS*.Png")
   End Sub
Function RéfFic(ByVal Racine As String, ParamArray PAMasques() As Variant) As String
   Dim FSO As New FileSystemObject, Dossier As Folder, Fichier As File, TMsq() As String, M&
   ReDim TMsq(1 To UBound(PAMasques) + 1)
   For M = 1 To UBound(TMsq): TMsq(M) = UCase$(PAMasques(UBound(TMsq) - M)): Next M
   On Error Resume Next
   Set Dossier = FSO.GetFolder(Racine)
   If Err Then RéfFic = "(" & Racine & " ?)": Exit Function
   Set Fichier = FicChrch(Dossier, TMsq)
   If Fichier Is Nothing Then RéfFic = "(" & Racine & ", " & Join(PAMasques, ", ") & " ?)": Exit Function
   RéfFic = Fichier.Path
   End Function
Private Function FicChrch(ByVal Doss As Folder, TMasques() As String) As File
   Dim TMasquesRestants() As String, UBTM&, Masque As String
   On Error Resume Next
   UBTM = UBound(TMasques): Masque = TMasques(UBTM)
   If UBTM > 1 Then
      TMasquesRestants = TMasques: ReDim Preserve TMasquesRestants(1 To UBTM - 1)
      For Each Doss In Doss.SubFolders
         If UCase$(Doss.Name) Like Masque Then Set FicChrch = FicChrch(Doss, _
            TMasquesRestants): If Not FicChrch Is Nothing Then Exit Function
         Next Doss
   Else
      For Each FicChrch In Doss.Files
         If UCase$(FicChrch.Name) Like Masque Then Exit Function
         Next FicChrch: End If
   End Function

 

[titymax]

Je pense avoir compris, des tests me le confirment, par contre comment puis je insérer cela dans mon projet ?

En effet, je lance une macro via un bouton de commande qui consiste à créer des lignes par rapport aux valeurs que l'opérateur a saisi dans des textbox et autres Combobox, et c'est à la fin de cette macro que je souhaite venir ajouter le lien dans une cellule.

Ainsi à chaque validation "OK" dans la Userform, une nouvelle ligne est créée dans mon tableau, via les lignes de code suivantes (extrait) :

Dim ligne As Long
lig = Range("C2000").End(xlUp).Offset(1, 0).Row
Range("A" & lig).Value = Me.ComboBox4.Value
Range("B" & lig).Value = Me.ComboBox5.Value
Range("E" & lig).Value = Me.ComboBox7.Value
Range("F" & lig).Value = Me.TextBox1.Value
Range("N" & lig).Value = Me.ComboBox3.Value

Il se trouve que la valeur X dont je parle depuis le début, est celle contenu dans la cellule ("F" & lig).Value et que le chemin est constitué de la manière suivante :

Une partie fixe appelée par ex PFIXE suivie d'une partie variable constituée de : \" & Range("E" & lig).Value & "\" & Range("N" & lig).Value

Ainsi le chemin est de la forme suivante : PFIXE\" & Range("E" & lig).Value & "\" & Range("N" & lig).Value

Comment puis je intégrer votre code pour arriver à mes fins ?