wisgest

Можно переименовать, например, на 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