كيفية تثبيت خط جديد

بسم الله

ردو الله يكرمكم

السلام عليكم

هذا كود تثبيت خط على الجهاز

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button to your form.
'Insert this code to the module :

Declare Function AddFontResource& Lib "gdi32" Alias "AddFontResourceA" _
(ByVal lpFileName As String)
Declare Function RemoveFontResource& Lib "gdi32" Alias "RemoveFontResourceA" _
(ByVal lpFileName As String)

'Insert this code to your form:

Private Sub Command1_Click()
Dim retvalue As Long
'Replace all 'MyFont' below with your font file.
retvalue = RemoveFontResource("c:\MyFont.ttf")
Command1.Caption = "uninstall"
End Sub

Private Sub Form_Load()
Dim retvalue As Long
Command1.Caption = "uninstall"
retvalue = AddFontResource("c:\MyFont.ttf")
Command1.FontName = "MyFont"
End Sub

والسلام عليكم

بسم الله

اشكرك اخي العزيز على هذا الرد لكن للأسف الكود لم يعمل

مفيش اي اخطاء بتظهر لكن في نفس الوقت الخط مش بيتثبت

ممكن بس شوية شرح او تعديل

وجزاك الله خيرا

بسم الله

محدش ناوي يرد برضو

للرفع

السلام عليكم يا معلم امير

جرب كده :

Private Const HWND_BROADCAST = &HFFFF&
Private Const WM_FONTCHANGE = &H1D
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 Any) As Long
Private Sub Form_Load()
	Dim res As Long
	' add the font
	res = AddFontResource("C:\Fonts\Nordic__.ttf")
	If res > 0 Then
		' alert all windows that a font was added
		SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
		MsgBox res & " fonts were added!"
	End If
End Sub

----------------------------------------------------------------------------------------------------------------------------------

أو

'Add a module to your project (In the menu choose Project -> Add Module, Then click Open)
'Add 1 Command Button to your form.
'Insert this code to the module :

Declare Function AddFontResource& Lib "gdi32" Alias "AddFontResourceA" _
(ByVal lpFileName As String)
Declare Function RemoveFontResource& Lib "gdi32" Alias "RemoveFontResourceA" _
(ByVal lpFileName As String)

'Insert this code to your form:

Private Sub Command1_Click()
Dim retvalue As Long
'Replace all 'MyFont' below with your font file.
retvalue = RemoveFontResource("c:\MyFont.ttf")
Command1.Caption = "uninstall"
End Sub

Private Sub Form_Load()
Dim retvalue As Long
Command1.Caption = "uninstall"
retvalue = AddFontResource("c:\MyFont.ttf")
Command1.FontName = "MyFont"
End Sub

----------------------------------------------------------------------------------------------------------------------------------

أو

في الفورم

Private Sub Form_Load()
	'The KPD-Team 2001
	'URL: http://www.allapi.net/
	'E-Mail: KPDTeam@Allapi.net
	AppPath = App.Path
	If Right$(AppPath, 1) <> "\" Then AppPath = AppPath + "\"
	'Add the font to the Windows Font Table
	AddFontResource AppPath + "myfont.ttf"
	'Write something on the form
	Me.AutoRedraw = True
	Me.FontName = "myfont"
	Me.Print "This is a test!"
End Sub
Private Sub Form_Unload(Cancel As Integer)
	'Remove the font from the Windows Font Table
	RemoveFontResource AppPath + "myfont.ttf"
End Sub

في موديول

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

جزاك الله خيراً

علاء ...

بسم الله

علاء باشا ازيك

جزاك الله خيرا على مشاركتك الجميلة الكبيرة دي

ايه ده كله يا راجل :D

بس بقولك ايه دي نفس الاكواد اللي تفضل بها الاخ قديم الشوق

مش شغالة برضو

جزاك الله خيرا تاني

:angry: