Autres Copie de répertoire (mais avec son icone)

[Michou9]

Bonjour à tous
J'utilise une macro pour copier des dossiers
Mais bizarrement lors de cette copie je perds son icone
Je ne comprends pas d'où cela peut venir
Et je viens chercher de l'aide sur le Forum
J'utilise Excel 2007

Sub CopieDossier()
Dim fs As Object, copie As Object
Set fs = CreateObject("Scripting.FileSystemObject")
Set copie = fs.GetFolder _
("C:\M\MonDossier")
copie.Copy "F:\Repertoire\A\1\"
End Sub

 

[patricktoulon]

en fait c'est facile à comprendre .".copy"d'un object fso.getfolder ou le ".copyfolder" de FSo copie tout en vbnormal
c'est pas plus compliqué que ca
il faut simplement lui remettre les attributs vbsystem pour le dossier et vbhidden+vbsystem pour le ".ini"

Donc ce que disait Nain porte quoi avait bien du bon !

ben non justement si dans les options de l'explorer et non le dossier "masquer les fichiers system est coché le ini n'est pas copié avec la case a cocher afficher les éléments masqués" ne sert que pour l'explorer
j'ai fait une vidéo qui le montre bien

pour info la copy avec personnalisation n'est plus automatique depuis win vista

 

[patricktoulon]

au passage kado
une petite fonction qui converti un png en ico ca peux servir pour mettre des iconnes perso
mais selon l'image de base on perd une peu les couleurs

Sub test()
    Dim pngPath$, icoPath$, monicon
    ' Chemins
    pngPath = "C:\Users\patricktoulon\Desktop\monimage.png"
    icoPath = "C:\Users\patricktoulon\Desktop\monicone.ico"
    monicon = ConvertPngToICO(pngPath, icoPath)
    
End Sub

Function ConvertPngToICO(pngPath, icoPath) As String ' avec PowerShell
    Dim psScript$, x, shellCmd As String
    psScript = "Add-Type -AssemblyName System.Drawing;" & _
                "$img = [System.Drawing.Image]::FromFile('" & pngPath & "');" & _
                "$bmp = New-Object System.Drawing.Bitmap $img, 100,100;" & _
                "$icon = [System.Drawing.Icon]::FromHandle($bmp.GetHicon());" & _
                "$stream = New-Object System.IO.FileStream('" & icoPath & "', 'Create');" & _
                "$icon.Save($stream); $stream.Close();"
    
    shellCmd = "powershell.exe -NoProfile -Command " & Chr(34) & psScript & Chr(34)
    Shell shellCmd, vbHide
    Do While Dir(icoPath) = "" Or x < 2: DoEvents: x = x + 0.0001: Loop
    If Dir(icoPath) <> "" Then ConvertPngToICO = icoPath
End Function

et pour le mettre dans le dossier

Sub test2()
    Dim dossier As String, icoPath As String
    dossier = "C:\Users\patricktoulon\Desktop\MonDossier"
    icoPath = "C:\Users\patricktoulon\Desktop\monicone.ico"
    'ou utiliser une filedialogpicker
    AppliquerICOauDossier dossier, icoPath
End Sub

Sub AppliquerICOauDossier(dossier, icoPath)
    Dim fs As Object, x, EcFini
    Dim fichierINI As String, ts As Object
    Set fs = CreateObject("Scripting.FileSystemObject")
    SetAttr dossier, vbNormal
    FileCopy icoPath, dossier & "\monicone.ico" ' Copier le fichier ICO dans le dossier
    fichierINI = dossier & "\desktop.ini"
    Set EcFini = fs.CreateTextFile(dossier & "\desktop.ini", True)
    EcFini.WriteLine "[.ShellClassInfo]" & vbCrLf & "IconResource=monicone.ico,0"
    EcFini.Close
    'Shell "attrib +s """ & dossier & """", vbHide ' oldversion :Marquer le dossier comme “système” et tout ces descendants pour que l’icône soit prise en compte
    SetAttr dossier, vbSystem
    MsgBox "Icone appliqué sur dossier !"
End Sub

on a fait le tour

Patrick

 

[Michou9]

Merci cela peut servir certainement
Moi je converti habituellement les JPG ou les PNG en BMP
Je les met en 256x256
Puis ensuite je change l'extension BMP en ICO
Cela donne de bon résultat

 

[Michou9]

Bonsoir patricktoulon
Il subsiste à un sérieux problème auquel je n'avais pas pensé
Lors de mes essais, je n'avais pas pensé aux sous-dossiers
Ces sous-dossiers ont eux aussi des icones
Les dossiers grâces votre code sont bien copier avec leurs icones
Les sous-dossiers sont bien copiés avec le dossiers, mais eux ils perdent tous leurs icones

 

[job75]

Moi je ne savais même pas qu'on pouvait mettre des icônes sur des dossiers, ça simplifie les choses 😎

 

[Michou9]

Moi je ne savais même pas qu'on pouvait mettre des icônes sur des dossiers, ça simplifie les choses 😎

Ceux là peut paraitre accessoire mais quand on a des centaines de dossiers, cela est très utiles pour visualiser certains dossiers pas rapport à d'autres

 

[Michou9]

Bonjour à tous
patricktoulon
En ligne de commande ou utilise l'option "/s" lorsque que l'on veut faire quelque chose sur l'ensemble d'un dossier
Je pense que si on pouvait mettre cette option dans cette ligne :
SetAttr Destination & newname & "\desktop.ini", vbHidden + vbSystem 'ajoute les propriété hidden et sytem au desktop.ini
cela pourrait résoudre le problème ??
J'ai bien tenté de le faire, mais en vain

 

[patricktoulon]

Bonjour @Michou9 voici la solution finale
elle te crée ou ajoute les manquants (sans ecraser ce qui existe !!) pour destination
elle copie le folder et tous les sous dossier (avec un nouveau nom ou pas )
elle pose l'attribut system (au dossier final et à tous ces sous dossiers)

du coup c'est une fonction réutilisable à volonté
testée sur win 10 excel 2013 et 2016

Sub test()
    Dim Source As String, NewName As String, Destination As String, copie As Boolean
    
    Source = "C:\Users\patricktoulon\Desktop\dossiertesticon" 'changer le dossier source ici
    NewName = "toto" 'nouveau nom pour le dossier
    Destination = "F:\Repertoire\A\1\" ' chemin de destination
    
    copie = CopyFolderAddAttrSystem(Destination, Source, NewName)
    MsgBox copie
End Sub

Function CopyFolderAddAttrSystem(Destination, Source, Optional NewName = "")
   'collection fonction folder /file 2026 par patricktoulon(archivé F ad228_2026)
   Dim fs As Object
        oldname = Mid(Source, InStrRev(Source, "\") + 1) 'recupération du nom du dossier
     'creation de l'arborescence de destination crée ou ajoute les manquants (n'ecrase pas l'existant)
    Shell "cmd /c mkdir """ & Destination & """", vbHide
    'Attente de la presence du dossier destination
    Do While Dir(Destination, vbDirectory) = "": DoEvents: Loop
    'Changement du nom du dossier (si newname n'est pas vide)
    chemin_final = Destination & IIf(NewName <> "", NewName, oldname) 'chemin final
    'instanciation de l'object FSO (Scripting FileSystemObject) de la scrunn.dll
    Set fs = CreateObject("Scripting.FileSystemObject")
    'copie du dossier
    fs.CopyFolder Source, chemin_final, True 'copie du dossier
    'Fermeture de FSO(devrait libérer le handle dossier)
    Set fs = Nothing
     'Ajout de l'attribut system au dossier racine
    Shell "cmd /c attrib +s """ & chemin_final & """ /d", vbHide
    'Ajout de l'attribut system a tous les sous-dossiers + fichiers
    Shell "cmd /c attrib +s """ & chemin_final & "\*"" /s /d", vbHide
    CopyFolderAddAttrSystem = Dir(chemin_final, vbDirectory + vbSystem) <> ""
End Function

j'ai testé plus de 50 fois aucune erreur

 

[Michou9]

Bonjour @Michou9 voici la solution finale
elle te crée ou ajoute les manquants (sans ecraser ce qui existe !!) pour destination
elle copie le folder et tous les sous dossier (avec un nouveau nom ou pas )
elle pose l'attribut system (au dossier final et à tous ces sous dossiers)

du coup c'est une fonction réutilisable à volonté
testée sur win 10 excel 2013 et 2016

Sub test()
    Dim Source As String, NewName As String, Destination As String, copie As Boolean
   
    Source = "C:\Users\patricktoulon\Desktop\dossiertesticon" 'changer le dossier source ici
    NewName = "toto" 'nouveau nom pour le dossier
    Destination = "F:\Repertoire\A\1\" ' chemin de destination
   
    copie = CopyFolderAddAttrSystem(Destination, Source, NewName)
    MsgBox copie
End Sub

Function CopyFolderAddAttrSystem(Destination, Source, Optional NewName = "")
   'collection fonction folder /file 2026 par patricktoulon(archivé F ad228_2026)
   Dim fs As Object
        oldname = Mid(Source, InStrRev(Source, "\") + 1) 'recupération du nom du dossier
     'creation de l'arborescence de destination crée ou ajoute les manquants (n'ecrase pas l'existant)
    Shell "cmd /c mkdir """ & Destination & """", vbHide
    'Attente de la presence du dossier destination
    Do While Dir(Destination, vbDirectory) = "": DoEvents: Loop
    'Changement du nom du dossier (si newname n'est pas vide)
    chemin_final = Destination & IIf(NewName <> "", NewName, oldname) 'chemin final
    'instanciation de l'object FSO (Scripting FileSystemObject) de la scrunn.dll
    Set fs = CreateObject("Scripting.FileSystemObject")
    'copie du dossier
    fs.CopyFolder Source, chemin_final, True 'copie du dossier
    'Fermeture de FSO(devrait libérer le handle dossier)
    Set fs = Nothing
     'Ajout de l'attribut system au dossier racine
    Shell "cmd /c attrib +s """ & chemin_final & """ /d", vbHide
    'Ajout de l'attribut system a tous les sous-dossiers + fichiers
    Shell "cmd /c attrib +s """ & chemin_final & "\*"" /s /d", vbHide
    CopyFolderAddAttrSystem = Dir(chemin_final, vbDirectory + vbSystem) <> ""
End Function

j'ai testé plus de 50 fois aucune erreur

Bonjour patricktoulon

Je suis bien content de te relire

Depuis 2 jours j’essaye de faire quelque chose
J’avais bien trouvé une solution, qui fonctionne bien, mais avec un code à rallonge et avec l’obligation de paramétrer tous les sous-dossiers

Là c’est super

J’ai mis 7 sous dossiers, tous avec des icones
Tout se copie parfaitement
Je vais continuer à le tester, mais là du coup, je ne vois quel problème je pourrais rencontré

Chapeau et un grand merci

 

[job75]

Bonjour à tous,

Utiliser VBA pour le copier-coller de dossiers semble bien inutile.

En effet je constate que le copier-coller manuel conserve les icônes.

Donc si tous les dossiers à copier sont dans un même répertoire il suffit de les sélectionner tous en même temps, de les copier et d'aller les coller dans un autre répertoire.

A+

 

[patricktoulon]

Bonjour @job75 ca n'a rien a voir avec le copier coller
en fait c'est justement le copier coller qui supprime le destop.ini de la base de registre des dossiers qui en contiennent un
du coup la personnalisation est non effective même si le ini est bien toujours dans le dossier

apres il va falloir que je m'attaque au problème pour changer le chemin de l'image quand les dossier sont copier ou deplacer car la le chemin d'un icone perso ne correspond plus au chemin dans le ini (a moins que je puisse mettre seulement le nom de l'icone comme celui ci est dans le dossier aussi

Patrick

 

[job75]

Bonjour @job75 ca n'a rien a voir avec le copier coller

Que dis-tu là ? le copier-coller manuel ce n'est pas du copier-coller ???

 

[dysorthographie]

bonjour,
et avec robocopy ?

Sub CopieDossier()

    Dim cmd As String
    
    cmd = "robocopy ""C:\M\MonDossier"" ""F:\Repertoire\A\1\MonDossier"" /E /COPYALL /R:0 /W:0"
    
    Shell cmd, vbHide

End Sub

 

[patricktoulon]

re
@dysorthographie
et c'est presque bon il faut supprimer l'audit "U" sinon problème de droit d'acces mais l'idée est bonne puisque la ligne corrigé j'ai bien mes iconnes qui sont restés en place
c'est vrai j'aurais du y penser à robocopy DAT

Sub CopieDossier()

    Dim cmd As String
   
    ' Créer le dossier
    'Shell "cmd /c mkdir ""F:\Repertoire\A\1""", vbHide
   
    ' Copier avec robocopy
  cmd = "cmd /c robocopy ""C:\Users\patricktoulon\Desktop\toto"" ""F:\Repertoire\A\1"" /E /COPY:DAT /R:0 /W:0 & pause"
  Shell cmd, vbNormalFocus

End Sub

@job75 non c'est une question d'enregistrement et d'accès au ini qui est plus accessible ou très peniblement par vba
avec des icon d'une dll (,x) y a pas trop de probleme mais avec un icone perso dans le dossier lui même le lien deviend erroné dans le ini apres copie ou deplacement

robocopyDAT fait le 75 fois mieux le job

robocopy DAT

-------------------------------------------------------------------------------
ROBOCOPY :: Copie de fichiers robuste pour Windows
-------------------------------------------------------------------------------

Début : mercredi 25 mars 2026 14:45:52
Source : C:\Users\patricktoulon\Desktop\toto\
Dest : F:\Repertoire\A\1\

Fichiers : *.*

Options : *.* /S /E /DCOPY😀A /COPY😀AT /R:0 /W:0

-------------------------------------------------------------------------------

1 C:\Users\patricktoulon\Desktop\toto\
100% Nouveau fichier 115 desktop.ini
Nouveau rép. 1 C:\Users\patricktoulon\Desktop\toto\dossier base2\
100% Nouveau fichier 114 desktop.ini
Nouveau rép. 1 C:\Users\patricktoulon\Desktop\toto\dossier base2\dossier unité\
100% Nouveau fichier 115 desktop.ini

-------------------------------------------------------------------------------

Total Copié IgnoréDiscordance ÉCHEC Extras
Rép : 3 2 1 0 0 0
Fichiers : 3 3 0 0 0 0
Octets : 344 344 0 0 0 0
Heures: 0:00:00 0:00:00 0:00:00 0:00:00


Débit : 26461 Octets/sec.
Débit : 1.514 Méga-octets/min.
Fin : mercredi 25 mars 2026 14:45:52

Appuyez sur une touche pour continuer...

robocopy U

-------------------------------------------------------------------------------
ROBOCOPY :: Copie de fichiers robuste pour Windows
-------------------------------------------------------------------------------

Début : mercredi 25 mars 2026 15:01:48
Source : C:\Users\patricktoulon\Desktop\toto\
Dest : F:\Repertoire\A\1\

Fichiers : *.*

Options : *.* /S /E /DCOPY😀 /COPY:U /R:0 /W:0

-------------------------------------------------------------------------------

ERREUR : vous ne disposez pas du droit de gestion d’audit.
***** Il est requis pour copier les informations d’audit (/COPY:U ou /COPYALL).

Syntaxe simple :: ROBOCOPY source destination /MIR

source :: répertoire source (lecteur:\chemin ou
\\serveur\partage\chemin).
destination :: rép. de destination (lecteur:\chemin ou
\\serveur\partage\chemin).
/MIR :: met en miroir une arborescence complète.

Pour plus d’informations sur son utilisation, exécutez ROBOCOPY /?


**** /MIR peut SUPPRIMER des fichiers en plus de les copier !
Appuyez sur une touche pour continuer...

 

[Michou9]

bonjour,
et avec robocopy ?

Sub CopieDossier()

    Dim cmd As String
  
    cmd = "robocopy ""C:\M\MonDossier"" ""F:\Repertoire\A\1\MonDossier"" /E /COPYALL /R:0 /W:0"
  
    Shell cmd, vbHide

End Sub

Bonjour job75, dysorthographie, re patricktoulon

Job785
Bien sûr, si il ne s’agissait juste de copier un répertoire avec ses sous-répertoires et ses icones
Je n’aurai pas demandé tout cela

Ce code est destiné à être intégré dans un autre code que j’ai déjà réalisé sur Excel
Et qui va permettre de mettre des données dans des dossiers
Pour pouvoir faire cela il faut que les dossiers soient réalisés pendant l’exécution de mon code

dysorthographie
Je viens de faire plusieurs essais,
Je n’ai pas d’erreur, mais il ne se copie rien du tout ?