XL 2016 colorier une ellipse en fonction d'un repertoire reseau

[christ77000]

Bonjour a tous , j'ai un code pour tester un chemin réseau. Il fonctionne bien. Mais cliquer sur un bouton a chaque fois pour savoir si c'est ok c'est pas terrible. Alors ma question est, à la place du message est il possible de colorier une ellipse en vert si ok et en rouge si pas bon. Merci pour votre aide.

Sub TesteCheminReseau()
Dim i, Chemin As String

Chemin = Range("D41").Value
On Error Resume Next
i = Dir(Chemin & "*.*")

If i = "" Then MsgBox "Ce chemin n'existe pas"

End Sub

 

[Hasco]

Bonjour,

Dans le fichier joint un essai avec un Nom : Chemin.Etat créé et modifié sur évènement Change de la feuille et deux possibilités, une par MFC et jeux d'icônes et l'autre par la police WebDings et une autre MFC. Je préfère cette dernière.

Ne pas oublier qu'un chemin quel qu’il soit peut être valide à un instant et non valide à un autre. Donc cette solution affiche la validité du chemin qu'aux moment ou une cellule change de valeur dans la feuille (On peut restreindre dans cet exemple, au changement de D4 uniquement)

Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("D4").Text <> "" Then
        Application.Names.Add ("Chemin.Etat"), (Dir(Range("D4").Text & "\*.*") <> "") * -1
    Else
        Application.Names.Add ("Chemin.Etat"), 0
    End If
End Sub

Cordialement

 

[sylvanu]

Bonjour Christ, Roblochon,
Juste un exemple pour colorer un shape, voir en PJ avec :

Sub ChangementCouleurShape()
Condition = [F1]
    If Condition = 1 Then
        ActiveSheet.Shapes("Ellipse 1").DrawingObject.Interior.Color = RGB(0, 255, 0)
        [F1] = 0
    Else
        ActiveSheet.Shapes("Ellipse 1").DrawingObject.Interior.Color = RGB(255, 0, 0)
        [F1] = 1
    End If
End Sub

 

[christ77000]

Bonjour et merci pour vos deux propositions, je retiendrais celle de Roblochon. Mais une petite question du coup j'ai trois lien a contrôler et j'ai essayer avec

Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("D38,D39,D41").Text <> "" Then
        Application.Names.Add ("Chemin.Etat"), (Dir(Range("D38,D39dD41").Text & "\*.*") <> "") * -1
    Else
        Application.Names.Add ("Chemin.Etat"), 0
    End If
   
End Sub

ca me change les 3

[U]sylvanu[/U] ta façon de faire m'a donnée des idées pour mon fichier. Une petite question ton bouton il vient d'Excel !! Merci

 

[sylvanu]

Re,
Vous faites Insertion/Formes et n'importe quelle forme.
Puis vous cliquez droit sur la forme et faites "Affecter une macro" et vous choisissez votre macro.
Ça marche aussi avec des images.

 

[christ77000]

Sylvanu, merci je venais de trouver.

 

[christ77000]

j'ai un chemin réseau du type \\Srvfichiersvjs007.toto.toto.toto\communication_v5$\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\ qui me fais planter le code

Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("D38").Text <> "" Then
        Application.Names.Add ("Chemin.Etat"), (Dir(Range("D38").Text & "\*.*") <> "") * -1
    Else
        Application.Names.Add ("Chemin.Etat"), 0
    End If
End Sub

est il possible de modifier ce code pour qu'il fonctionne également comme un chemin du type c:\Users\Christophe\Desktop\ Merci pour votre aide

 

[christ77000]

j'ai essayer en retirant le \ de
Application.Names.Add ("Chemin.Etat"), (Dir(Range("D38").Text & "\*.*") <> "") * -1

marche pas non plus... et pas trouver pour contrôler trois liens non plus

 

[Hasco]

Re,

De retour mais trop tard pour ce soir, je verrai demain si j'ai le temps. Mais pour trois chemins, il faudra trois noms et trois Applications.Names.Add.

Je ne vois pas de raison à l'échec d'un chemin tel que ; c:\Users\Christophe\Desktop\

???

Cordialement

 

[christ77000]

ca plante sur un chemin du type
\\toto.toto.net\communication_v5$\1. Sécurité & Environnement\Accidents & analyse 5 pourquoi et arbres des causes\
et justement pas sur c:\Users\Christophe\Desktop\

 

[christ77000]

re
en faite ca plante pas ca ne trouve pas le chemin mais du coup le code plante. Serrait 'il possible alors de modifier ce code pour qu'il ne plante plus, et affiche 1 si ok et 0 si non ok

Private Sub Worksheet_Change(ByVal Target As Range)
    If Range("D38").Text <> "" Then
        Application.Names.Add ("Chemin.Etat"), (Dir(Range("D38").Text & "\*.*") <> "") * -1
    Else
        Application.Names.Add ("Chemin.Etat"), 0
    End If
End Sub

je me suis inspire aussi de ce code mais qui plante aussi si le chemin qui n'existe pas

Public Function DossierExiste(MonDossier as String)

   If Len(Dir(MonDossier, vbDirectory)) > 0 Then
      DossierExiste = True
   Else
      DossierExiste = False
   End If
End Function

Sub TesteSiDossierExiste()
Dim MonDossier As String

MonDossier = Range("D38").Value

    If DossierExiste(MonDossier) = True Then
        Range("W38").Value = 1
    Else
        Range("W38").Value = 0
    End If

End Sub

et celui-ci me fait planter Excel. je vous joint un extrait de mon fichier. Merci

 

[Hasco]

Bonjour,

Pour les chemins réseau je vous conseille la lecture de https://excel-malin.com/codes-sources-vba/obtenir-adresse-reseau-de-fichier-unc/ et de tester ses macros.

N'ayant plus de réseaux à ma portée, je ne peux tester.

Bonne continuation