Регистрация шрифта средствами VB6
Формулировка задачи:
Всем привет!
Ткните носом. попадалась на глаза тема. Не могу найти...
Решение задачи: «Регистрация шрифта средствами VB6»
textual
Листинг программы
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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д