How to rename font files to their original names?

Question

Fonts

Please tell me how to rename the font files to their original names, which are specified in the properties

Answer 1

You can rename, for example, to VBScript, using the methods of the Shell.Application object to get the properties of the file : ExtendedPropertyor GetDetailsOf. For the first one, you need to know the textual name of the property, I haven’t been able to find it out yet, and it’s not always there. For the second - a numerical index, it can be found out empirically , I got 21, but on other machines there may be a different number.
Things did not work out with fonts with the FON extension (raster?): they have the value of the property I found does not differ for the font varieties in different files. But with True Type fonts (TTF extension) something happened. However, in the case when the name differs only in case, I did not rename it, because then the error “File already exists” occurs.

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

Answer 2

Try it with Total Commander, I think it has a mass rename command, including meta attributes

Answer 3

I continue the topic on my blog - https://serhii.lutsk.city/y6e1A0znO