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

Download IconAnyFolder (vbs file)

  1. '============================================== 'NAME: IconAnyFolder.vbs ' 'AUTHOR: Scott Greenberg 'COMPANY: SG Technology 'WEBSITE: http://gogogadgetscott.info 'Date :     4/21/2004 'VERSION: 1.0 ' 'DESCRIPTION: This script will customizes Each 'of the Sub folders listed under the specified '"sStartFolder" With a descriptive icon. ' 'COMMENTS: Portions of subroutine WriteKey were derived 'from "Work With INI files In VBS" v1.00 'by: Antonin Foller, PSTRUH Software, http://www.pstruh.cz ' 'HISTORY: '4/21/2004, 1.0v - First release ' 'Copyright© 2004. SG Technology. All rights reserved. '============================================== sStartFolder = "D:\Text Editors" 'Set default value iDTfiles = 0 CRLF = Chr (13) + Chr (10) sTitle = "Icon Any Folder" 'Display a welcome message Welcome() 'Set up objects For use Set oFSO = CreateObject ("Scripting.FileSystemObject") Set oWSH = CreateObject ("WScript.Shell") 'Start operation Start(sStartFolder) sMsg = "Script Is complete. " & iDTfiles & " folders have been customized." MsgBox sMsg, vbInformation , sTitle 'Requires a folder path To start search Sub Start(sPath)   'On Error Resume Next   Set oFolder = oFSO.GetFolder(sPath)   'For Each Folder In oFolder.SubFolders     SetIcon(oFolder)   'Next End Sub 'Find icon For given folder Function SetIcon(oFolder)   'On Error Resume Next   SetIcon = ""   bFoundIcon = False   For Each File In oFolder.Files     If LCase (Right (File.Name,3)) = "ico" Then       If GoodIcon(File.Name, oFolder.Name) Then         bFoundIcon = True         Exit For       End If     End If   Next   If bFoundIcon = False Then     For Each File In oFolder.Files       If LCase (Right (File.Name,3)) = "exe" Then         If GoodIcon(File.Name, oFolder.Name) Then           bFoundIcon = True           Exit For         End If       End If     Next   End If   'If bFoundIcon = False Then     'For Each File In oFolder.Files       'If LCase (Right (File.Name,3)) = "dll" Then         'If GoodIcon(File.Name, oFolder.Name) Then           'bFoundIcon = True           'Exit For         'End If       'End If     'Next   'End If   For Each Folder In oFolder.SubFolders     SubIcon = SetIcon(Folder)   Next   If bFoundIcon = True Then     SetIcon = oFolder.Path & "\" & File.Name & "," & 0     WriteDTfile oFolder, SetIcon   Else     SetIcon = SubIcon & "," & 0   End If    End Function 'Requires a file path that may Or may Not be a valid icon file, String 'Returns True of If file Is a valid icon file, Boolean Function GoodIcon(FileName, FolderName)   GoodIcon = True   'Check If file Is a uninstall program   'If Then Not a good icon choice To describe folder   If Not InStr (LCase (FileName), "unins") = 0 Then GoodIcon = False   If Not InStr (LCase (FileName), "setup") = 0 Then GoodIcon = False End Function 'Setup folder Sub WriteDTfile(Folder, sIconFile)   'Extract icon location And index   aIcon = Split (sIconFile, ",")   If aIcon(0) = "" Then Exit Sub   If Not IsNumeric (aIcon(1)) Then aIcon(1) = 0   sDTfile = Folder.path & "\Desktop.ini"   WriteKey ".ShellClassInfo", "IconFile", SysEnvRe(aIcon(0)), sDTfile   WriteKey ".ShellClassInfo", "IconIndex", aIcon(1), sDTfile   'mark folder As read-only To make use of Desktop config file   If (Folder.Attributes And 1) <> 1 Then   Folder.Attributes = Folder.Attributes + 1   'Update count of created Desktop conf files   iDTfiles = iDTfiles + 1 End Sub 'Write key To desktop configuration file Sub WriteKey(Section, KeyName, Value, FileName)   On Error Resume Next   'Get contents of the desktop file As a String   If oFSO.FileExists(FileName) Then     Set fDT = oFSO.GetFile(FileName)     'Set attributes To nomal, allow appending     fDT.Attributes = 0     INIContents = ""     Set TextStream = fDT.OpenAsTextStream(1)     Do While Not TextStream.AtEndOfStream       INIContents = INIContents & TextStream.ReadLine & CRLF     Loop     TextStream.Close     'remove last CRLF     If Len (INIContents) > 3 Then       INIContents = Left (INIContents, Len (INIContents) - 2)     End If   Else     INIContents = ""   End If   'Find section   PosSection = InStr (1, INIContents, "[" & Section & "]")   If PosSection > 0 Then     'Section exists, find End of section     PosEndSection = InStr (PosSection, INIContents, CRLF & "[")     'Check If this Is last section     If PosEndSection = 0 Then PosEndSection = Len (INIContents) + 1     'Separate section contents     OldsContents = Mid (INIContents, PosSection, PosEndSection - PosSection)     OldsContents = Split (OldsContents, CRLF)     'Temp variable To find a Key     sKeyName = LCase (KeyName & "=")     'Enumerate section lines     For Each Line In OldsContents       If LCase (Left (Line, Len (sKeyName))) = sKeyName Then         Line = KeyName & "=" & Value         Found = True       End If       NewContents = NewContents & Line & CRLF     Next     If IsEmpty (Found) Then       'key Not found - add it at the End of section       NewContents = NewContents & KeyName & "=" & Value     Else       'remove last CRLF - CRLF Is at PosEndSection       NewContents = Left (NewContents, Len (NewContents) - 2)     End If     'Combine pre-section, New section And post-section data     NewContents = Left (INIContents, PosSection - 1) & NewContents     NewContents = NewContents & Mid (INIContents, PosEndSection)   Else     'Section Not found, add section data at the End of file contents     If Right (INIContents, 2) <> CRLF And Len (INIContents) > 0 Then       INIContents = INIContents & CRLF     End If     NewContents = INIContents & "[" & Section & "]" & CRLF & KeyName & "=" & Value   End If   Set TextStream = oFSO.CreateTextFile(FileName, True )   TextStream.Write NewContents   TextStream.Close   Set fDT = oFSO.GetFile(FileName)   'mark file As hidden And read-only To protect it from being modified   fDT.Attributes = fDT.Attributes + 3 End Sub 'Requires a folder Or file path, String 'Returns path With any known system variables, String 'Can prevent broken links, sometimes Function SysEnvRe(path)   SysEnvRe = path   vars = Array ("APPDATA", "ALLUSERSPROFILE", "USERPROFILE", "ProgramFiles", "SystemRoot")   Set SysEnv = oWSH.Environment("PROCESS")   'Loop through environment variables   For Each var In vars     SysEnvRe = Replace (SysEnvRe, SysEnv(var),"%" & var & "%")   Next End Function 'Sub To display welcome message Sub Welcome()   sMessage = "This script will customizes Each of the folders" & _   " listed In " & sStartFolder & " With descriptive icons."   iAns = MsgBox (sMessage, vbOKCancel + vbInformation , sTitle)   If iAns = vbCancel Then     WScript.Quit   End If End Sub

Download IconAnyFolder (vbs file)