Регистрация шрифта средствами VB6

Option Explicit
 
Private Declare Function AddFontResource Lib "gdi32.dll" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function CopyFile Lib "kernel32" Alias "CopyFileA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal bFailIfExists As Long) As Long
 
Private Sub Command1_Click()
    
                    Dim WshShell        As Object
                    Dim FontPath        As String
                    Dim retCodes        As Long
                    Dim intI            As Integer
                    Dim intISucsCopy    As Integer
                    Dim intISucsRegs    As Integer
                    Dim intIErrCopy     As Integer
                    Dim intIErrRegs     As Integer
                    Dim intFreeNoom     As Integer
    
    
    Set WshShell = CreateObject("WScript.Shell")
    FontPath = WshShell.SpecialFolders("Fonts") ' определяем системную папку со шрифтами
    intFreeNoom = FreeFile
    
    
    Open App.Path & "\InstFont.log" For Append As #intFreeNoom  ' лог файл
      
      Print #intFreeNoom, ""
      Print #intFreeNoom, "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
      Print #intFreeNoom, "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Start LOG ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
      Print #intFreeNoom, "~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~"
      Print #intFreeNoom, "Date - "; Date
      Print #intFreeNoom, "Time - "; Time
      Print #intFreeNoom, ""
      
      For intI = 0 To File1.ListCount - 1
         
                 '
                 ' копируем шрифты в системную папку
                 '
                 
                 retCodes = CopyFile(App.Path & "\" & File1.List(intI), FontPath & "\" & File1.List(intI), 0)
                 
                    '
                    ' пишем лог
                    '
                    
                    If retCodes = 0 Then
                       Print #intFreeNoom, "Copy files - " & App.Path & "\" & File1.List(intI) & " to " & FontPath & "\" & File1.List(intI) & " { Error }"
                       intIErrCopy = intIErrCopy + 1
                    Else
                       Print #intFreeNoom, "Copy files - " & App.Path & "\" & File1.List(intI) & " to " & FontPath & "\" & File1.List(intI) & " { Success }"
                       intISucsCopy = intISucsCopy + 1
                    End If
                 
                '
                ' пробуем зарегистрировать
                '
                    
                retCodes = AddFontResource(FontPath & "\" & File1.List(intI))
                
                    '
                    ' пишем лог
                    '
                
                
                    If retCodes = 0 Then
                      Print #intFreeNoom, "Reg. files  - " & FontPath & "\" & File1.List(intI) & " { Error }"
                      intIErrRegs = intIErrRegs + 1
                    Else
                       Print #intFreeNoom, "Reg.files  - " & FontPath & "\" & File1.List(intI) & " { Success }"
                       intISucsRegs = intISucsRegs + 1
                    End If
                    
                    Print #intFreeNoom, ""
      Next intI
            
        Print #intFreeNoom, "Total files        : " & File1.ListCount
        Print #intFreeNoom, "Success copy files : " & intISucsCopy
        Print #intFreeNoom, "Error copy files   : " & intIErrCopy
        Print #intFreeNoom, "Success Reg files  : " & intISucsRegs
        Print #intFreeNoom, "Error Reg files    : " & intIErrRegs
    
    Close #intFreeNoom
            
            '
            ' результаты в студию....
            '
        
        Shell "notepad.exe" & " " & App.Path & "\InstFont.log"
    End
    
End Sub
 
Private Sub Form_Load()
    File1.Pattern = "*.ttf"
    If File1.ListCount = 0 Then Command1.Enabled = False
    Label2.Caption = "Foud Font:" & File1.ListCount
End Sub
 
Private Sub Text1_Change()
    File1.Pattern = Text1
    If File1.ListCount = 0 Then Command1.Enabled = False Else Command1.Enabled = True
    Label2.Caption = "Foud Font:" & File1.ListCount
End Sub