Comment créer Chemin relatif dans une Macro

jlm94

XLDnaute Junior
Bonjour,

Dans nos planning Généraux nous avons, pour chaque feuille, une macro explicite faisant référence à un fichier excel
qui nous permet d'affecter automatiquement une mise en forme à chaque cellule d'une plage en fonction de la valeur saisie.

Ces fichiers se trouvent sur un serveur NAS et chaque utilisateur accède à ces fichiers via un lecteur réseau.

Dans cette Macro, le chemin du fichier2 "coloris-animateurs.xlsx" est indiqué sous la forme
Lettre du lecteur réseau:\chemin du fichier\nom du fichier

ce qui oblique chaque utilisateur a avoir la même lettre pour ce lecteur réseau.

Existe t'il un moyen de s'affranchir de cette lettre de lecteur. car chaque utilisateur possède plusieurs lecteurs réseaux et pour unifier une lettre, il faudrait recréer chaque lecteur en choisissant une lettre qui est dispo chez chacun.

Merci par avance.

Voici la macro:
Code:
Option Explicit
Dim fplage As Range, cel As Range
Dim estouvert As Byte
Dim Chemin As String, fichier1 As String, fichier2 As String
Dim fich As Workbook


Private Sub Worksheet_Change(ByVal Target As Range)

Application.ScreenUpdating = False



'****************************************************************************************************************
' Consulter la gestion des erreurs en cas d'erreur et renvoyer le message associé (voir en fin de macro)*********
'****************************************************************************************************************
    
    On Error GoTo gestion_erreur
    
'****************************************************************************************************************
'****************************************************************************************************************



Chemin = ThisWorkbook.Path 'chemin du fichier actuel
fichier1 = ThisWorkbook.Name 'nom du fichier actuel
fichier2 = "U:\RH\Coloris-Animateurs.xlsx" 'chemin du fichier "Coloris-Animateurs.xlsx"[/COLOR]



'****************************************************************************************************************
' Contrôler si le classeur "Coloris-Animateurs" est ouvert ******************************************************
'****************************************************************************************************************

estouvert = 0 'donner la valeur 0 à cette variable

For Each fich In Workbooks
    If fich.Name = "Coloris-Animateurs.xlsx" Then estouvert = 1 'passer à 1 si le fichier est ouvert
Next

If estouvert = 0 Then Workbooks.Open (fichier2) 's'il n'est pas ouvert, on l'ouvre et on l'active
Windows("Coloris-Animateurs.xlsx").Activate

Set fplage = Sheets(1).Range("A2:A" & Sheets(1).Range("A1").End(xlDown).Row) 'plage de recherche

Windows(fichier1).Activate 'on revient sur le premier classeur

'****************************************************************************************************************
'****************************************************************************************************************



If Not Intersect(Target, Range("C11:BB41")) Is Nothing Then 'plage modifiable :cellule C41 à BB41

    For Each cel In Intersect(Target, Range("C11:BB41"))
        
        If cel = "" Then
        
            cel.Interior.ColorIndex = xlNone
            cel.Font.ColorIndex = xlAutomatic
                        
        ElseIf cel <> "" Then
        
            cel.Interior.Color = fplage.Find(Target.Value, , LookIn:=xlValues, lookat:=xlWhole).Interior.Color
            cel.Font.Color = fplage.Find(Target.Value, , LookIn:=xlValues, lookat:=xlWhole).Font.Color
            
        End If
        
    Next cel
        
End If

Application.DisplayAlerts = False 'désactiver les alertes
Workbooks("Coloris-Animateurs.xlsx").Save 'on sauvegarde les dernières modifications du classeur "Coloris-Animateurs"
Workbooks("Coloris-Animateurs.xlsx").Close
Application.DisplayAlerts = True 'réactiver les alertes

'****************************************************************************************************************
' Gestion des erreurs *******************************************************************************************
'****************************************************************************************************************

gestion_erreur:

    If Err.Number = 91 Then
        MsgBox "Le nom introduit n'existe pas dans la liste Coloris-Animateurs " & chr(13) & chr(13) & _
        "Allez sur le classeur Coloris-Animateurs et ajoutez le nom." & chr(13) & _
        "Revenez sur le planning et réintroduisez le nouveau nom." _
        , vbExclamation, "Nom absent de la liste Coloris-Animateurs"
    End If
        
'****************************************************************************************************************
'****************************************************************************************************************



Application.ScreenUpdating = True

End Sub
 

Staple1600

XLDnaute Barbatruc
Re : Comment créer Chemin relatif dans une Macro

Bonjour à tous

jlm94
Voir de ce côté
(en cherchant sur le net avec ces mots-clés : VBA get UNC path , tu trouveras beaucoup d'autres exemples ou infos)
Code:
Function Path2UNC(sFullName As String) As String
   ' Converts the mapped drive path in sFullName to a UNC path if one exists.
   ' If not, returns a null string


   Dim sDrive      As String
   Dim i           As Long


   sDrive = UCase(Left(sFullName, 2))


   With CreateObject("WScript.Network").EnumNetworkDrives
       For i = 0 To .Count - 1 Step 2
           If .Item(i) = sDrive Then
               Path2UNC = .Item(i + 1) & Mid(sFullName, 3)
               Exit For
           End If
       Next
   End With
End Function 'source: shg -MVP
 

Discussions similaires

Statistiques des forums

Discussions
311 720
Messages
2 081 909
Membres
101 836
dernier inscrit
karmon