This script will customizes each of the sub folders listed under the specified "sStartFolder" with a descriptive icon.

Download IconAnyFolder (vbs file)

  1. '==============================================
  2. 'NAME: IconAnyFolder.vbs
  3. '
  4. 'AUTHOR: Scott Greenberg
  5. 'COMPANY: SG Technology
  6. 'WEBSITE: http://gogogadgetscott.info
  7. 'Date :     4/21/2004
  8. 'VERSION: 1.0
  9. '
  10. 'DESCRIPTION: This script will customizes Each
  11. 'of the Sub folders listed under the specified
  12. '"sStartFolder" With a descriptive icon.
  13. '
  14. 'COMMENTS: Portions of subroutine WriteKey were derived
  15. 'from "Work With INI files In VBS" v1.00
  16. 'by: Antonin Foller, PSTRUH Software, http://www.pstruh.cz
  17. '
  18. 'HISTORY:
  19. '4/21/2004, 1.0v - First release
  20. '
  21. 'Copyright© 2004. SG Technology. All rights reserved.
  22. '==============================================
  23. sStartFolder = "D:\Text Editors"
  24. 'Set default value
  25. iDTfiles = 0
  26. CRLF = Chr (13) + Chr (10)
  27. sTitle = "Icon Any Folder"
  28. 'Display a welcome message
  29. Welcome()
  30. 'Set up objects For use
  31. Set oFSO = CreateObject ("Scripting.FileSystemObject")
  32. Set oWSH = CreateObject ("WScript.Shell")
  33. 'Start operation
  34. Start(sStartFolder)
  35. sMsg = "Script Is complete. " & iDTfiles & " folders have been customized."
  36. MsgBox sMsg, vbInformation , sTitle
  37. 'Requires a folder path To start search
  38. Sub Start(sPath)
  39.   'On Error Resume Next
  40.   Set oFolder = oFSO.GetFolder(sPath)
  41.   'For Each Folder In oFolder.SubFolders
  42.   SetIcon(oFolder)
  43.   'Next
  44. End Sub
  45. 'Find icon For given folder
  46. Function SetIcon(oFolder)
  47.   'On Error Resume Next
  48.   SetIcon = ""
  49.   bFoundIcon = False
  50.   For Each File In oFolder.Files
  51.     If LCase (Right (File.Name,3)) = "ico" Then
  52.       If GoodIcon(File.Name, oFolder.Name) Then
  53.         bFoundIcon = True
  54.         Exit For
  55.       End If
  56.     End If
  57.   Next
  58.   If bFoundIcon = False Then
  59.     For Each File In oFolder.Files
  60.       If LCase (Right (File.Name,3)) = "exe" Then
  61.         If GoodIcon(File.Name, oFolder.Name) Then
  62.           bFoundIcon = True
  63.           Exit For
  64.         End If
  65.       End If
  66.     Next
  67.   End If
  68.   'If bFoundIcon = False Then
  69.   'For Each File In oFolder.Files
  70.   'If LCase (Right (File.Name,3)) = "dll" Then
  71.   'If GoodIcon(File.Name, oFolder.Name) Then
  72.   'bFoundIcon = True
  73.   'Exit For
  74.   'End If
  75.   'End If
  76.   'Next
  77.   'End If
  78.   For Each Folder In oFolder.SubFolders
  79.     SubIcon = SetIcon(Folder)
  80.   Next
  81.   If bFoundIcon = True Then
  82.     SetIcon = oFolder.Path & "\" & File.Name & "," & 0
  83.     WriteDTfile oFolder, SetIcon
  84.   Else
  85.     SetIcon = SubIcon & "," & 0
  86.   End If
  87.   
  88. End Function
  89. 'Requires a file path that may Or may Not be a valid icon file, String
  90. 'Returns True of If file Is a valid icon file, Boolean
  91. Function GoodIcon(FileName, FolderName)
  92.   GoodIcon = True
  93.   'Check If file Is a uninstall program
  94.   'If Then Not a good icon choice To describe folder
  95.   If Not InStr (LCase (FileName), "unins") = 0 Then GoodIcon = False
  96.   If Not InStr (LCase (FileName), "setup") = 0 Then GoodIcon = False
  97. End Function
  98. 'Setup folder
  99. Sub WriteDTfile(Folder, sIconFile)
  100.   'Extract icon location And index
  101.   aIcon = Split (sIconFile, ",")
  102.   If aIcon(0) = "" Then Exit Sub
  103.   If Not IsNumeric (aIcon(1)) Then aIcon(1) = 0
  104.   sDTfile = Folder.path & "\Desktop.ini"
  105.   WriteKey ".ShellClassInfo", "IconFile", SysEnvRe(aIcon(0)), sDTfile
  106.   WriteKey ".ShellClassInfo", "IconIndex", aIcon(1), sDTfile
  107.   'mark folder As read-only To make use of Desktop config file
  108.   If (Folder.Attributes And 1) <> 1 Then   Folder.Attributes = Folder.Attributes + 1
  109.   'Update count of created Desktop conf files
  110.   iDTfiles = iDTfiles + 1
  111. End Sub
  112. 'Write key To desktop configuration file
  113. Sub WriteKey(Section, KeyName, Value, FileName)
  114.   On Error Resume Next
  115.   'Get contents of the desktop file As a String
  116.   If oFSO.FileExists(FileName) Then
  117.     Set fDT = oFSO.GetFile(FileName)
  118.     'Set attributes To nomal, allow appending
  119.     fDT.Attributes = 0
  120.     INIContents = ""
  121.     Set TextStream = fDT.OpenAsTextStream(1)
  122.     Do While Not TextStream.AtEndOfStream
  123.       INIContents = INIContents & TextStream.ReadLine & CRLF
  124.     Loop
  125.     TextStream.Close
  126.     'remove last CRLF
  127.     If Len (INIContents) > 3 Then
  128.       INIContents = Left (INIContents, Len (INIContents) - 2)
  129.     End If
  130.   Else
  131.     INIContents = ""
  132.   End If
  133.   'Find section
  134.   PosSection = InStr (1, INIContents, "[" & Section & "]")
  135.   If PosSection > 0 Then
  136.     'Section exists, find End of section
  137.     PosEndSection = InStr (PosSection, INIContents, CRLF & "[")
  138.     'Check If this Is last section
  139.     If PosEndSection = 0 Then PosEndSection = Len (INIContents) + 1
  140.     'Separate section contents
  141.     OldsContents = Mid (INIContents, PosSection, PosEndSection - PosSection)
  142.     OldsContents = Split (OldsContents, CRLF)
  143.     'Temp variable To find a Key
  144.     sKeyName = LCase (KeyName & "=")
  145.     'Enumerate section lines
  146.     For Each Line In OldsContents
  147.       If LCase (Left (Line, Len (sKeyName))) = sKeyName Then
  148.         Line = KeyName & "=" & Value
  149.         Found = True
  150.       End If
  151.       NewContents = NewContents & Line & CRLF
  152.     Next
  153.     If IsEmpty (Found) Then
  154.       'key Not found - add it at the End of section
  155.       NewContents = NewContents & KeyName & "=" & Value
  156.     Else
  157.       'remove last CRLF - CRLF Is at PosEndSection
  158.       NewContents = Left (NewContents, Len (NewContents) - 2)
  159.     End If
  160.     'Combine pre-section, New section And post-section data
  161.     NewContents = Left (INIContents, PosSection - 1) & NewContents
  162.     NewContents = NewContents & Mid (INIContents, PosEndSection)
  163.   Else
  164.     'Section Not found, add section data at the End of file contents
  165.     If Right (INIContents, 2) <> CRLF And Len (INIContents) > 0 Then
  166.       INIContents = INIContents & CRLF
  167.     End If
  168.     NewContents = INIContents & "[" & Section & "]" & CRLF & KeyName & "=" & Value
  169.   End If
  170.   Set TextStream = oFSO.CreateTextFile(FileName, True )
  171.   TextStream.Write NewContents
  172.   TextStream.Close
  173.   Set fDT = oFSO.GetFile(FileName)
  174.   'mark file As hidden And read-only To protect it from being modified
  175.   fDT.Attributes = fDT.Attributes + 3
  176. End Sub
  177. 'Requires a folder Or file path, String
  178. 'Returns path With any known system variables, String
  179. 'Can prevent broken links, sometimes
  180. Function SysEnvRe(path)
  181.   SysEnvRe = path
  182.   vars = Array ("APPDATA", "ALLUSERSPROFILE", "USERPROFILE", "ProgramFiles", "SystemRoot")
  183.   Set SysEnv = oWSH.Environment("PROCESS")
  184.   'Loop through environment variables
  185.   For Each var In vars
  186.     SysEnvRe = Replace (SysEnvRe, SysEnv(var),"%" & var & "%")
  187.   Next
  188. End Function
  189. 'Sub To display welcome message
  190. Sub Welcome()
  191.   sMessage = "This script will customizes Each of the folders" & _
  192.   " listed In " & sStartFolder & " With descriptive icons."
  193.   iAns = MsgBox (sMessage, vbOKCancel + vbInformation , sTitle)
  194.   If iAns = vbCancel Then
  195.     WScript.Quit
  196.   End If
  197. End Sub

Download IconAnyFolder (vbs file)