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

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

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