'    Bodoni MT Black   72
'    Harlow Solid Italic  8
'    Calibri     11

Const sFont = "Harlow Solid Italic"
Const sSize = "8"

'    HKEY_CURRENT_USER\Software\Microsoft\Office\14.0\Excel\Options
Const sPref = "HKEY_CURRENT_USER\Software\Microsoft\Office\"
Const sSuff = "\Excel\Options\Font"
dim sKey: sKey = sPref & sGetVersion & sSuff

dim sVal
' sVal = sFont & "," & sSize
sVal = InputBox("Введи шрифт в формате:" & vbCr & _
     "[Название],[Размер]",, "Calibri,11")
If Len(sVal) = 0 Then WScript.Quit

SetRegVal sKey, sVal

Dim xl: Set xl = CreateObject("Excel.Application")
Dim wb: Set wb = xl.Workbooks.Add
wb.SaveAs sGetCurrentDirectory & "\" & sVal & ".xls", 56  
wb.Close
xl.Quit
Set wb = Nothing
Set xl = Nothing

'===========================================================================================
Function sGetVersion()
  Dim xl: Set xl = CreateObject("Excel.Application")
  sGetVersion = xl.Version
  xl.Quit
  Set xl=Nothing
End Function

Function sGetCurrentDirectory()
  Dim WshShell: Set WshShell = CreateObject("WScript.Shell")
  'Определяем каталог, из которого был запущен сценарий(текущий каталог)
  sGetCurrentDirectory = WshShell.CurrentDirectory
End Function

'-------------------------------------------------------------- РЕЕСТР ---
Sub SetRegVal(sPath, sVal)
     On Error Resume Next
     Dim WshShell: Set WshShell = CreateObject("WScript.Shell")
     WshShell.RegWrite sPath, sVal, "REG_SZ"   
End Sub

Function sGetRegVal(sPath)
     On Error Resume Next
     Dim WshShell: Set WshShell = CreateObject("WScript.Shell")
     sGetRegVal = WshShell.RegRead(sPath)      
End Function