Вопрос по API Visual Basic

[С.М.С]

Доброй ночи всем!
приведённый ниже Код должен программно устанавливать шрифт fonet_tm.
при выполнении выводит ошибку - File not found:GDI - и выдиляет часть кода, но ни в этом суть можно удалить эту часть кода, тогда выделит следующюю часть и туже ошибку. Я так понимаю Ошибка в присваивании значении - FontName$, FontFileName$, WinSysDir$

' FontName$ is the font's name (e.g. "Goudy Old Style")
'
' FontFileName$ is the font's filename (e.g. "GOUDOS.TTF")
'
' WinSysDir$ is the user's System folder (e.g.
' "C:\WINDOWS\SYSTEM"
' or "C:\WINDOWS\SYSTEM32")

эти пяснения в аригинале были к коду

Помогите разобраться!


Declare Function WriteProfileString Lib "Kernel" (ByVal _
lpApplicationName As String, ByVal lpKeyName As String, _
ByVal lpString As String) As Integer

Declare Function CreateScalableFontResource% Lib "GDI" _
(ByVal fHidden%, ByVal lpszResourceFile$, ByVal _
lpszFontFile$, ByVal lpszCurrentPath$)

Declare Function _
AddFontResource Lib "GDI" (ByVal lpFilename As Any) As _
Integer

Declare Function SendMessage Lib "User" (ByVal hWnd As _
Integer, ByVal wMsg As Integer, ByVal wParam As _
Integer, lParam As Any) As Long


Sub Install_TTF (FontName$, FontFileName$, WinSysDir$)
Dim Ret%, Res&, FontPath$, FontRes$
Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF

FontPath$ = WinSysDir$ + "\" + FontFileName$
FontRes$ = Left$(FontPath$, Len(FontPath$) - 3) + "FOT"

Ret% = CreateScalableFontResource(0, FontRes$, _
FontFileName$, WinSysDir$)
Ret% = AddFontResource(FontRes$)
Res& = SendMessage(HWND_BROADCAST, WM_FONTCHANGE, 0, 0)
Ret% = WriteProfileString("fonts", FontName + " " & _
"(TrueType)", FontRes$)
End Sub



const FontName$ = "fonet_tm"
const FontFileName$ = "fonet_tm.ttf"
const WinSysDir$ = "C:\Documents and Settings\С.М.С\Рабочий стол"

Call Install_TTF (FontName$, FontFileName$, WinSysDir$)

[alexBlack]

Сообщение от С.М.С

Доброй ночи всем!
приведённый ниже Код должен программно устанавливать шрифт fonet_tm.
при выполнении выводит ошибку - File not found:GDI - и выдиляет часть кода, но ни в этом суть можно удалить эту часть кода, тогда выделит следующюю часть и туже ошибку. Я так понимаю Ошибка в присваивании значении - FontName$, FontFileName$, WinSysDir$

Возьмите другой код. Например
http://www.microsoft.com/Rus/Msdn/Ac.../Other/91.mspx
http://www.ex-designz.net/apidetail.asp?api_id=587
http://www.answers.com/topic/addfontresource

увидите разницу.

[С.М.С]

Спасибо большое alexBlack! Работает!
взял код с первой ссылки(приведён ниже)

Option Explicit
#If Win32 Then
Private Declare Function AddFontResource Lib _
"gdi32" Alias "AddFontResourceA" (ByVal _
lpFileName As String) As Long
Private Declare Function SendMessage Lib _
"user32" Alias "SendMessageA" (ByVal hWnd _
As Long, ByVal wMsg As Long, ByVal wParam _
As Long, lParam As Long) As Long
Private Declare Function GetWindowsDirectory _
Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As _
Long) As Long
#Else
Private Declare Function AddFontResource Lib _
"GDI" (ByVal lpFilename As Any) As Integer
Private Declare Function SendMessage Lib "User" _
(ByVal hWnd As Integer, ByVal wMsg As Integer, _
ByVal wParam As Integer, lParam As Any) As Long
Private Declare Function GetWindowsDirectory _
Lib "Kernel" (ByVal lpBuffer As String, ByVal _
nSize As Integer) As Integer
#End If

Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF&

Function AddFont3 (FileName As String) As Integer
Dim WindowsDir As String
Dim Lbuf As Long
' - Получение каталога Windows
Lbuf = GetWindowsDirectory (WindowsDir, Len (Buffer))
If Lbuf Then
WindowsDir = Left$(windowsDir, Lbuf)
' - Копирование файла
FileCopy FileName, WindowsDir & "\Fonts\" & FileName
' - Добавление шрифта
If AddFontResource (FileName) Then
SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
AddFont3 = True
End If
End If
End Function

несрабатывало копирование шрифта- ошика вот в этой строчки
FileCopy FileName, WindowsDir & "\Fonts\" & FileName
одинаковые адреса откуда брать шрифт и куда копировать
В общем кому интересно ниже переделанный вариант

(размещается в начале модуля)

Private Declare Function AddFontResource Lib _
"gdi32" Alias "AddFontResourceA" (ByVal _
lpFilename As String) As Long
Private Declare Function SendMessage Lib _
"user32" Alias "SendMessageA" (ByVal hWnd _
As Long, ByVal wMsg As Long, ByVal wParam _
As Long, lParam As Long) As Long
Private Declare Function GetWindowsDirectory _
Lib "kernel32" Alias "GetWindowsDirectoryA" _
(ByVal lpBuffer As String, ByVal nSize As _
Long) As Long


Const WM_FONTCHANGE = &H1D
Const HWND_BROADCAST = &HFFFF&

Sub AddFont3(FileName, puteFileName)
' показываем путь папки Windows
Dim windir As String ' получаем путь папки Windows
Dim slength As Long ' получаем длину возвращаемой строки

windir = Space(255) 'отводим место для получения строки в буфере
slength = GetWindowsDirectory(windir, 255) ' узнаём путь папки
windir = Left(windir, slength) ' получаем имя из буфера

If Dir$(windir & "\Fonts\" & FileName) = "" Then
' - Копирование файла
FileCopy puteFileName, windir & "\Fonts\" & FileName
' - Добавление шрифта
If AddFontResource(FileName) Then
SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0

End If
End If
End Sub

(Далее вызываем процедуру)
'имя шрифта
Const FileName = "fonet_tm.ttf"
'его путь с именем
Const puteFileName = "C:\Documents and Settings\С.М.С\Рабочий стол\fonet_tm.ttf"
'вызов процедуры
Call AddFont3(FileName, puteFileName)