Добро пожаловать в форум, Guest  >>   Войти | Регистрация | Поиск | Правила | В избранное | Подписаться
Все форумы / Visual Basic Новый топик    Ответить
 Установка шрифта программно  [new]
час58
Member

Откуда: г. Энгельс.
Сообщений: 1562
Покажите, кто знает, как программно, из VB6 установить шрифт?
Система Windows
Шрифт UPC-A.ttf
--------------------------------------------------------------------------
СПС
26 июн 16, 13:56    [19336790]     Ответить | Цитировать Сообщить модератору
 Re: Установка шрифта программно  [new]
час58
Member

Откуда: г. Энгельс.
Сообщений: 1562
Код получился вот такой.

Public Function FUN_FONT_IN_SYSTEM()

Dim GLB_PATCH_Windows
'==========================================================================
'установка шрифта в систему.
'==========================================================================

Set FSO = New Scripting.FileSystemObject
    Dim WSH
    Set WSH = CreateObject("WScript.Shell")
    'Копирование файла шрифта в системную папку шрифтов
    GLB_PATCH_Windows = Environ("windir") ' путь к Windows
  FSO.CopyFile App.Path & "\OKZ\FONT\UPC-A.ttf", GLB_PATCH_Windows & "\Fonts\UPC-A.ttf"
    'Установка шрифта вызовом API
    WSH.Run "RunDll32.exe gdi32.dll, AddFontResourceA " & GLB_PATCH_Windows & "\Fonts\UPC-A.ttf"

End Function


Но шрифт в папке Font системой не распознаётся.
А потому не устанавливается.
В чём проблема?
Что я делаю не так?
26 июн 16, 19:58    [19337406]     Ответить | Цитировать Сообщить модератору
Между сообщениями интервал более 1 года.
 Re: Установка шрифта программно  [new]
Nik_Kurta
Member

Откуда: Россия, Симферополь
Сообщений: 66
Option Explicit

Private Declare Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
Private Declare Function RemoveFontResource Lib "gdi32.dll" Alias "RemoveFontResourceA" (ByVal lpFileName As String) As Long

'--------------------------------------------------------------------------------
'Function: {fnIsFont}
'--------------------------------------------------------------------------------
Public Function fnIsFont(strPatchNameFont As String) As Boolean
    Dim fso As New FileSystemObject
    Dim i As Long
    If fso.FileExists(strPatchNameFont) = True Then
        i = RemoveFontResource(strPatchNameFont) '- DELETE
        i = AddFontResource(strPatchNameFont)    '- ADD
        If i > 0 Then
            fnIsFont = True
        Else
            fnIsFont = False
        End If
    Else
        fnIsFont = False
    End If
    Set fso = Nothing
End Function
21 сен 17, 17:34    [20813254]     Ответить | Цитировать Сообщить модератору
 Re: Установка шрифта программно  [new]
час58
Member

Откуда: г. Энгельс.
Сообщений: 1562
Nik_Kurta,

Спасибо за ответ.
21 сен 17, 18:26    [20813375]     Ответить | Цитировать Сообщить модератору
Все форумы / Visual Basic Ответить