Можно переименовать, например, на VBScript, используя для получения свойств файла методы объекта
Shell.Application:
ExtendedProperty или
GetDetailsOf. Для первого надо знать текстовое наименование свойства, его узнать у меня пока не получилось, да и не всегда оно есть. Для второго —числовой индекс, его можно узнать
опытным путём, у меня получилось 21, но на других машинах может быть другое число.
Дело не пошло со шрифтами с расширением FON (растровыми?): у них значение найденного мной свойства не отличается для разновидностей шрифта в разных файлах. Но со шрифтами True Type (расширение TTF) что-то получилось. Впрочем, в случае, когда имя отличается лишь регистром, я переименовывать не стал, так как тогда возникает ошибка «Файл уже существует».
Const PROPERTY_INDEX = 21
' ВНИМАНИЕ:
' Индес PROPERTY_INDEX свойства, содержащего название шрифта,
' определён опытным путём
' <http://forum.script-coding.com/viewtopic.php?id=38>
' и зависит от установленного программного обеспечения!!!
Set Shell = CreateObject("Shell.Application")
Const BIF_RETURNONLYFSDIRS = &H1
Const BIF_EDITBOX = &H10
Const BIF_NONEWFOLDERBUTTON = &H200
Do
Set Folder = Shell.BrowseForFolder(0, WScript.ScriptName, _
BIF_RETURNONLYFSDIRS Or BIF_EDITBOX Or BIF_NONEWFOLDERBUTTON)
If Folder Is Nothing Then WScript.Quit
If Folder.Self.Path = Shell.NameSpace("shell:Fonts").Self.Path Then
MsgBox "C системной папкой шрифтов не работает!", _
vbExclamation, WScript.ScriptName
Else
Exit Do
End If
Loop
Set FolderItems = Folder.Items()
Count = FolderItems.Count
Redim Items(Count - 1)
For I = 0 to Count - 1
Set Items(I) = FolderItems.Item(I)
Next
Set FSO = CreateObject("Scripting.FileSystemObject")
For Each Item In Items
Path = Item.Path
ExtensionName = FSO.GetExtensionName(Path)
If UCase(ExtensionName) = "TTF" Then
FontTitle = Folder.GetDetailsOf(Item, PROPERTY_INDEX)
If UCase(FontTitle) <> UCase(FSO.GetBaseName(Path)) Then
OldName = FSO.GetFile(Path).Name
NewName = FontTitle & "." & ExtensionName
On Error Resume Next
FSO.GetFile(Path).Name = NewName
If Err Then MsgBox _
OldName & " => " & NewName & vbNewLine & _
Err.Description, vbExclamation, WScript.ScriptName
On Error GoTo 0
End If
End If
Next
MsgBox "Конец.", vbInformation, WScript.ScriptName
