عايز كود يقو بتسطيب خط .. مرفق مع ملف أكسس .. المسار مش محدد

[qathi]

ممكن كود يقوم بتسطيب خط أو أكثر من خط .. تكون الخطوط موجوده في فولدر مرفق مع ملف أكسس .. بشرط يكون مسار الخطوط المراد تسطيبها مش محدد زي مثلاً

D:\Pakedge\digital-7.ttf

يفضل أن يكون:

Pakedge\digital-7.ttf

[صالح حمادي]

السلام عليكم:

تفضل هذا الكود و معه مثال:

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 أمر0_Click()

Dim res As Long
' add the font
res = AddFontResource(CurrentProject.Path & "\DS-DIGI.ttf")
If res > 0 Then
' alert all windows that a font was added
SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
MsgBox "لقد تم إضافة الخط بنجاح"
End If
End Sub

 

إضافة خط للونداوز.rar

[عاشق الرقي]

ماشاء الله أستاذ صالح

جعله الله في ميزان حسناتك

[qathi]

شكرا أستاذ @صالح حمادي على ردك فعلا هذا هو المطلوب  .. لكن أذا أردنا تثبيت أكثر من خط ثلاثة أو أكثر .. فكيف يكون الكود؟ .. ثانياً: ياريت يكون مسار الخط المرفق داخل فولدر يسمى Fonts

[صالح حمادي]

4 ساعات مضت, عاشق الرقي said:

ماشاء الله أستاذ صالح

جعله الله في ميزان حسناتك

شكرا جزيلا أخي

3 ساعات مضت, qathi said:

لكن أذا أردنا تثبيت أكثر من خط ثلاثة أو أكثر .. فكيف يكون الكود؟

نكرر نفس الكود على حسب عدد الخطوط

3 ساعات مضت, qathi said:

ثانياً: ياريت يكون مسار الخط المرفق داخل فولدر يسمى Fonts

نضيف اسم الفولدر لهذا السطر:

res = AddFontResource(CurrentProject.Path & "\fonts\DS-DIGI.ttf")

 

[qathi]

 أستاذ @صالح حمادي فعلاً كما تكرمت بالرد  .. متبقي فقط أعرف كم عدد الخطوط التي تم تسطيبها والفاشلة 

وشكرا لك .. وجعل الله هذا العمل في ميزان حسناتك

مرفق الملف الاخير

 

إضافة الخطوط للويندوز.rar

تم تعديل سبتمبر 5, 2018 بواسطه qathi