Discussion :

[RDR1905]

Bonjour,
Après copie d'1 dossier avec sous-dossiers depuis ma boite Dropbox vers un serveur via une macro, je n'arrive pas via une autre macro à affecter les icônes.
Lors de la copie, il ne garde que le fichier icône *.ico et supprime le fichier desktop.ini
J'arrive a le créer, a entrer les valeurs dans ce même fichier pas cela ne fonctionne pas !
Je ne sais pas si c'est un problèmes de droits, d'encodage (UTF-8) ou autre, mais je cale.
J'ai besoin d'un petit coup de pouce

voici le code, je suis en Win 10 + excel 2016

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
 
' MISE A JOUR DES ICONES D'UN DOSSIER ET DE CES SOUS-DOSSIERS
Sub maj_ico_dos(ByVal nom_clas_macro As Variant, ByVal nom_macro As Variant, ByVal nom_clas_actif As Variant, ByVal nom_fe As Variant, ByVal ch_dos As Variant, ByVal v6 As Variant, ByVal v7 As Variant, ByVal v8 As Variant, ByVal v9 As Variant, ByVal v10 As Variant)
  Stop
 
  ' Affectation icone au dossier racine
  Call trait_dos(ch_dos)
 
  ' Parcourir 1 dossier et ces sous-dossiers
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dos_rep = fs.GetFolder(ch_dos)
 
  ' Appel fonction recurante pour les sous-dossier
  Lit_dossier dos_rep, 1
 
End Sub
 
Sub Lit_dossier(ByRef dossier, ByVal niveau)
  For Each d In dossier.SubFolders
    ' Affectation icone au dossier racine
    Call trait_dos(d)
    Lit_dossier d, niveau + 1
   Next
End Sub
 
' Traitement des fichiers
Sub trait_dos(ByRef ch_dos)
  ' Rechercher le 1er fichier Icone "*.ico" d'un repertoire (visible et caché)
  Dim fic_ico As String
  fic_ico = Dir(ch_dos & "\" & "*.ico", vbHidden + vbSystem)  ' Extraire liste des fichiers "*.ico"
  If Len(fic_ico) < 1 Then
    Exit Sub
  Else
    Debug.Print ch_dos & fic_ico
  Else
  Dim MyFile As String: MyFile = ch_dos & "\" & fic_ico ': SetAttr MyFile, vbHidden
 
  ' Supprimer fichier "desktop.ini" si existant
  Set objFSO = New FileSystemObject
  On Error Resume Next ' si pas de fichier existant
  Set objMonFichier = objFSO.GetFile(ch_dos & "\desktop.ini")
  objMonFichier.Delete
 
  ' Créer fichier "desktop.ini" dans la racine du dossier
  Open ch_dos & "\" & "desktop" & ".ini" For Output As #1 ' For Binary
    Print #1, "; classe utilisé"
    Print #1, "[.ShellClassInfo]"
    Print #1, "; avertissement sur opération dossier"
    Print #1, "ConfirmFileOp=0"
    Print #1, "; Fichier Image pour icone"
    Print #1, "IconFile=" & fic_ico
    Print #1, "; Adresse icone d'IconFile si fichier mettre 0"
    Print #1, "IconIndex=0"
    Print #1, "; gestion partage dossier 0=oui et 1=non"
    Print #1, "Sharing = 0"
    Print #1, "; propriétaire fichier"
    Print #1, "Owner=Cancé"
  Close #1
  ' Modifier les attribut du fichier créer
  MyFile = ch_dos & "\" & "desktop" & ".ini"
  SetAttr MyFile, vbHidden + vbSystem '+ vbReadOnly
 
End Sub

Par avance merci

[RDR1905]

Bonsoir,
après plusieurs recherche, voici la macro qui fonctionne (problèmes d'attributs fichier mais aussi dossier)
Merci à 'rubilacxe' macro de 2006

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
 
' ***********************************************************
' MISE A JOUR DES ICONES D'UN DOSSIER ET DE CES SOUS-DOSSIERS
Sub maj_ico_dos(ByVal nom_clas_macro As Variant, ByVal nom_macro As Variant, ByVal nom_clas_actif As Variant, ByVal nom_fe As Variant, ByVal ch_dos As Variant, ByVal v6 As Variant, ByVal v7 As Variant, ByVal v8 As Variant, ByVal v9 As Variant, ByVal v10 As Variant)
  ' Affectation icone au dossier racine
  Call trait_dos(ch_dos)
  ' Parcourir 1 dossier et ces sous-dossiers
  Set fs = CreateObject("Scripting.FileSystemObject")
  Set dos_rep = fs.GetFolder(ch_dos)
  ' Appel fonction recurante pour les sous-dossier
  Lit_dossier dos_rep, 1
End Sub
' Recurence des sous-dossiers
Sub Lit_dossier(ByRef dossier, ByVal niveau)
  For Each d In dossier.SubFolders
    ' Affectation icone au dossier racine
    Call trait_dos(d)
    Lit_dossier d, niveau + 1
   Next
End Sub
' Traitement des fichiers
Sub trait_dos(ByRef ch_dos)
  ' Rechercher le 1er fichier Icone "*.ico" d'un repertoire (visible et caché)
  Dim fic_ico As String: fic_ico = Dir(ch_dos & "\" & "*.ico", vbHidden + vbSystem) ' Extraire liste des fichiers "*.ico"
  If Len(fic_ico) < 1 Then Exit Sub Else Debug.Print ch_dos & fic_ico               ' Tester si nombre fichier <> de 0
  Dim MyFile As String: MyFile = ch_dos & "\" & fic_ico ': SetAttr MyFile, vbHidden
  ' Supprimer fichier "desktop.ini" si existant
  Set objFSO = New FileSystemObject
  On Error Resume Next
  Set objMonFichier = objFSO.GetFile(ch_dos & "\desktop.ini")
  objMonFichier.Delete
  ' Création et attributs fichier desktop.ini et dossier racine
  Dim Path As String: Path = ch_dos                 ' Chemin complet du rep à créer
  Dim icon As String: icon = ch_dos & "\" & fic_ico ' Chemin complet de l'cone à insérer"
  Dim F As Integer: F = FreeFile()
  'Création du fichier ini
  Open Path & "\Desktop.ini" For Output As #F
    Print #F, "[.ShellClassInfo]"
    Print #F, "IconFile=" & icon
    Print #F, "IconIndex=0"
    Print #F, "ConfirmFileOp=1"
    Print #F, "InfoTip=Répertoire avec icone personnalisée"
   Close #F
   'Le dossier possède un attribut système
   SetAttr Path, vbSystem
   'Le fichier possède les attributs système et caché
   SetAttr Path & IIf(Right$(Path, 1) = "\", "", "\") & "Desktop.ini", vbSystem + vbHidden
End Sub