Вариант скрипта с автоматическим\полуавтоматическим поиском файла иконок:
Код: Выделить всё
'=========================================================================
' Задание иконок у папок (создание файлов desktop.ini)
' Параметры:
' {папка|файл-список папок} [{файл с иконкой} [{режим поиска файла с иконкой}]]
' где режим поиска файла с иконкой может принимать значения:
' 0 - обязательно должен быть задан файл с иконкой;
' 1 - если не задан файл с иконкой, выполняется автоматический поиск;
' 2 - если автоматически файл не найден, прелагается указать его вручную;
' 3 - всегда предлагается указать файл вручную (по умолчанию).
'
' Примеры параметров вызова из TC:
' "%P" "%N"
' %P%N %T%M
' %L "" 2
'
' Автор - Batya
'=========================================================================
Option Explicit
'======== Изменяемые параметры ===========================================
Const FileName = "Desktop.ini"
Const DefaultMode = 3 'Режим поиска файла с иконкой по умолчанию
Const FoldAttr = 1 'Атрибуты папки - "Только чтение"
Const FileAttr = 38 'Атрибуты файла - "Скрытый", "Системный", "Архивный"
'=========================================================================
Dim Mess, FSO, WSH, ListFlag, FF, IconFile, F, Errors, Mode
SetMess
Set Errors = CreateObject("Scripting.Dictionary")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSH = CreateObject("WScript.Shell")
CheckParam
If ListFlag Then
For Each F In Split(FSO.OpenTextFile(FF).ReadAll, vbNewLine)
If F <> "" Then Main F
Next
Else
Main FF
End If
If Errors.Count > 0 Then
MessBox JoinErr(Errors), 2
'Else
' MessBox Mess(7), 3
End If
Quit
Sub SetMess
Set Mess = CreateObject("Scripting.Dictionary")
With Mess
.Add 0, "Задание иконки для папки"
.Add 1, "Не указаны параметры!"
.Add 2, "Первый параметр не является папкой или файлом-списком!"
.Add 3, "Указанный файл с иконкой не существует!"
.Add 4, "Не является папкой!"
.Add 5, "Файл с иконкой не определен!"
.Add 6, "Файл " & FileName & " уже существует!"
.Add 7, "Операция завершена."
.Add 8, "Операция завершена с ошибками." & vbNewLine
.Add 9, "Укажите файл иконок для папки "
.Add 10, "Исполняемые файлы (*.exe)|*.exe|Файлы иконок (*.ico)|*.ico|Все файлы (*.*)|*.*"
.Add 11, "Неправильно указан режим поиска файла иконок!"
.Add 12, "В данном режиме файл с иконкой должен быть указан обязательно!"
End With
End Sub
Sub Main(pF)
Dim lF, lIF
lF = GetPath(pF)
If Not FSO.FolderExists(lF) Then
Errors.Add lF, lF & " - " & Mess(4)
Exit Sub
End If
lIF = GetIconFile(lF, IconFile)
If lIF = "" Then
Errors.Add lF, lF & " - " & Mess(5)
Exit Sub
End If
'Установим атрибуты папки
SetFoldAttr lF
'Создадим Desktop.ini
If Not FSO.FileExists(lF & "\" & FileName) Then
CreateDesktopFile lF & "\" & FileName, lIF
Else
Errors.Add lF, lF & " - " & Mess(6)
Exit Sub
End If
End Sub
Sub CheckParam
If WScript.Arguments.Count = 0 Then
MessBox Mess(1), 1
Quit
End If
FF = WScript.Arguments(0)
ListFlag = FSO.FileExists(FF)
If (Not ListFlag) And (Not FSO.FolderExists(FF)) Then
MessBox Mess(2), 1
Quit
End If
If WScript.Arguments.Count > 1 Then
IconFile = WScript.Arguments(1)
If IconFile <> "" Then IconFile = GetPath(IconFile)
Else
IconFile = ""
End If
If WScript.Arguments.Count > 2 Then
Mode = WScript.Arguments(2)
If Mode = "" Then
Mode = DefaultMode
Else
If IsNumeric(Mode) Then
Mode = CInt(Mode)
Else
MessBox Mess(11), 1
Quit
End If
If Not((Mode = 0) Or (Mode = 1) Or (Mode = 2) Or (Mode = 3)) Then
MessBox Mess(11), 1
Quit
End If
End If
Else
Mode = DefaultMode
End If
If (Mode = 0) And (IconFile = "") Then
MessBox Mess(12), 1
Quit
End If
If (IconFile <> "") And (Not FSO.FileExists(IconFile)) Then
MessBox Mess(3), 1
Quit
End If
End Sub
Sub Quit
Set Errors = Nothing
Set WSH = Nothing
Set FSO = Nothing
WScript.Quit
End Sub
Function MessBox(pMess, pMode)
Dim lIcon
Select Case pMode
Case 1 lIcon = vbCritical + vbOKOnly
Case 2 lIcon = vbExclamation + vbOKOnly
Case 3 lIcon = vbInformation + vbOKOnly
End Select
MessBox = MsgBox(pMess, lIcon, Mess(0))
End Function
Function JoinErr(pDic)
Dim lKey
For Each lKey In pDic
JoinErr = JoinErr & vbNewLine & vbNewLine & pDic(lKey)
Next
JoinErr = Mess(8) & JoinErr
End Function
Sub CreateDesktopFile(pFile, pIconFile)
Dim oFile
Set oFile = FSO.CreateTextFile(pFile)
With oFile
.WriteLine "[.ShellClassInfo]"
.WriteLine "IconFile=" & pIconFile
.WriteLine "IconIndex=0"
.Close
End With
Set oFile = FSO.GetFile(pFile)
oFile.Attributes = oFile.Attributes or FileAttr
Set oFile = Nothing
End Sub
Sub SetFoldAttr(pFolder)
Dim oDir
Set oDir = FSO.GetFolder(pFolder)
oDir.Attributes = oDir.Attributes or FoldAttr
Set oDir = Nothing
End Sub
Function GetPath(pPath)
GetPath = FSO.GetAbsolutePathName(WSH.ExpandEnvironmentStrings(pPath))
End Function
Function GetIconFile(pFolder, pFile)
Dim lFile
If Mode = 0 Then
GetIconFile = pFile
Exit Function
End If
If Mode < 3 Then
If pFile <> "" Then
GetIconFile = pFile
Exit Function
Else
lFile = pFolder & "\" & FSO.GetBaseName(pFolder) & ".exe"
If FSO.FileExists(lFile) Then
GetIconFile = lFile
Exit Function
End If
For Each lFile In FSO.GetFolder(pFolder).Files
If UCase(FSO.GetExtensionName(lFile)) = "EXE" Then
If (UCase(Left(lFile, 5)) <> "UNINS") Or _
(UCase(FSO.GetBaseName(lFile)) <> "UNWISE") Then
GetIconFile = lFile
Exit Function
End If
End If
Next
If Mode = 2 Then
GetIconFile = OpenFile(pFolder)
Else
GetIconFile = ""
End If
End If
Else
GetIconFile = OpenFile(pFolder)
End If
End Function
Function OpenFile(pFolder)
Dim Dlg
On Error Resume Next
Set Dlg = CreateObject("MSComDlg.CommonDialog")
If Err.Number = 0 Then
On Error GoTo 0
With Dlg
.InitDir = pFolder
.Filter = Mess(10)
.Flags = &H4 + &H8 + &H400 + &H1000 + &H80000
.FilterIndex = 1
.MaxFileSize = 32000
.CancelError = True
.DialogTitle = Mess(9) & """" & pFolder & """"
On Error Resume Next
.ShowOpen
End With
If Err.Number = 0 Then
OpenFile = Dlg.FileName
Else
OpenFile = ""
End If
On Error GoTo 0
Set Dlg = Nothing
Else
On Error GoTo 0
Dlg = InputBox(Mess(9) & """" & pFolder & """", Mess(0), pFolder & "\")
If Dlg <> "" Then Dlg = GetPath(Dlg)
If Not FSO.FileExists(Dlg) Then Dlg = ""
OpenFile = Dlg
End If
End Function
Может работать для нескольких выделенных папок.
Если будут проблемы с лицензией на объект MSComDlg, нужно поправить реестр вот этим reg-файлом:
Код: Выделить всё
REGEDIT4
[HKEY_CLASSES_ROOT\Licenses\4D553650-6ABE-11cf-8ADB-00AA00C00905]
@="gfjmrfkfifkmkfffrlmmgmhmnlulkmfmqkqj"
[HKEY_CLASSES_ROOT\Licenses\78E1BDD1-9941-11cf-9756-00AA00C00908]
@="yjrjvqkjlqqjnqkjvprqsjnjvkuknjpjtoun"
Если объект MSComDlg вообще не создается, нужно найти и зарегистрировать COMDLG32.OCX.
Нет, я не сплю. Я просто медленно моргаю.
