استفاده از فونت دلخواه در برنامه

[tc1000]

من در بعضی از برنامه ها مالتی مدیا دیدیم که چند تا فونت رو داخل یک فولدر نگهداری میکنند. و تمام نوشته های برنامه شون با اون فونتها نشون میده جالب اینه توی ویندوز هم فونت ها رو کپی نمی کنه.
چطور میشه این کار رو کرد؟

[noorsoft]

هنگامی که برنامه میخاد اجرا بشه فونتها را در ویندوز رجیست میکنن همین طور که میدونید لازم نیست همه فونها در شاخه فونتز ویندوز کپی شوند و در نهایت هنگام خروج فوت را از رجیستر در میارن

[shamsoft]

خب فونت رو چطور رجیستر می کنن؟

[noorsoft]

ساده است




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
' This sub installs a TrueType font and makes it available
' to
' all Windows apps. It takes these arguments:
'
' 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")
'
' ** Before calling this sub, your code must copy the font
' file
' to the user's Fonts folder. **
'
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

[alirzn]

این کد رو کجا باید بنویسم؟


ساده است





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
' This sub installs a TrueType font and makes it available
' to
' all Windows apps. It takes these arguments:
'
' 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")
'
' ** Before calling this sub, your code must copy the font
' file
' to the user's Fonts folder. **
'
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

[mf_engineer]

می تونی این رو توی ماژول بنویسی و بعد اون تابع رو توی لود اولین فرمت صدا بزنی