Option Explicit
Public Function RéfFicApprox(ByVal Racine As String, ParamArray PAMasques() As Variant) As String
Rem. ——— Renvoie une référence de fichier à partir d'éléments partiellement connus de son identification.
' Arguments à spécifier :
' Racine: L'identification d'un dossier parfaitement connu, sans caractère jocker.
' PAMasques: Une succession d'arguments en nombre variable pouvant être munis ou non de caractères
' jockers supporté par l'opérateur Like de VBA. Les premiers définissent le profil de chaque nom
' de sous-dossier, seul le dernier définit le profil de nom du fichier cherché.
' Toutefois si aucun fichier de ce profil n'est trouvé, il le cherche encore dans les
' sous-dossiers éventuels du dernier spécifié, l'avant dernier PAMasques, donc.
' Conseil: veillez à ce que vos spécification n'obligent pas la fonction à chercher dans des chemin trop
' nombreux et chargés, sinon son évaluation pourrait durer plusieurs minutes à cause d'élément auxquel
' on aura été à cent lieues de penser, tant ils seront étrangers à celui recherché …
' Remarque: s'il n'est pas trouvé de fichier correspondant, un texte commençant par une parenthèse
' ouvrante est renvoyé.
' Important. Nécessite la référence Microsoft Scripting Runtime (bibliothèque Scripting, fichier scrrun.dll).
Dim M&, FSO As New FileSystemObject, Dossier As Folder, TMsq() As String, Fichier As File
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éfFicApprox = "(" & Racine & " ?)": Exit Function
On Error GoTo 0
Set Fichier = FicApprox(Dossier, TMsq): If Fichier Is Nothing Then RéfFicApprox = "(" & _
Racine & ", " & Join(PAMasques, ", ") & " ?)" Else RéfFicApprox = Fichier.Path
End Function
Private Function FicApprox(ByVal Doss As Folder, TMasques() As String) As File
Dim UBTMq&, Masque As String, TMasquesRestants() As String
On Error Resume Next
UBTMq = UBound(TMasques): Masque = TMasques(UBTMq)
If UBTMq = 1 Then
For Each FicApprox In Doss.Files
If UCase$(FicApprox.Name) Like Masque Then Exit Function
Next FicApprox
For Each Doss In Doss.SubFolders
Set FicApprox = FicApprox(Doss, TMasques)
If Not FicApprox Is Nothing Then Exit Function
Next Doss
Else
TMasquesRestants = TMasques: ReDim Preserve TMasquesRestants(1 To UBTMq - 1)
For Each Doss In Doss.SubFolders
If UCase$(Doss.Name) Like Masque Then
Set FicApprox = FicApprox(Doss, TMasquesRestants)
If Not FicApprox Is Nothing Then Exit Function
End If
Next Doss: End If
End Function
