تثبيت خطوط للويندوز عن فتح قاعدة بيانات

[figo82eg]

ارجو المساعدة حيث لدى قاعدة بيانات بجوارها ملف اسمه الخطوط بداخله الخطوط المستخدمة بالقاعدة.

ما اريده هو عند فتح قاعدة البيانات يتم تثبيت جميع الخطوط داخل الملف  بشكل تلقائى دون تدخل من اى مستخدم.

[ناقل]

54 دقائق مضت, figo82eg said:

ارجو المساعدة حيث لدى قاعدة بيانات بجوارها ملف اسمه الخطوط بداخله الخطوط المستخدمة بالقاعدة.

ما اريده هو عند فتح قاعدة البيانات يتم تثبيت جميع الخطوط داخل الملف  بشكل تلقائى دون تدخل من اى مستخدم.

جرب واعلمنا ... لاني لم اجربه
#If VBA7 Then
    Private Declare PtrSafe Function AddFontResource Lib "gdi32" Alias "AddFontResourceA" (ByVal lpFileName As String) As Long
    Private Declare PtrSafe Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hWnd As LongPtr, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
    Private Const HWND_BROADCAST As LongPtr = &HFFFF&
#Else
    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, ByVal lParam As Long) As Long
    Private Const HWND_BROADCAST As Long = &HFFFF&
#End If

Private Const WM_FONTCHANGE As Long = &H1D

Sub InstallFonts()
    Dim dbPath As String
    Dim fontsFolder As String
    Dim fontFile As String
    Dim fontName As String
    Dim fso As Object
    Dim folder As Object
    Dim file As Object
    Dim fontInstalled As Boolean
    
    ' الحصول على مسار قاعدة البيانات ومجلد الخطوط
    dbPath = CurrentProject.Path
    fontsFolder = dbPath & "\الخطوط"
    
    ' التحقق إذا كان مجلد الخطوط موجودًا
    Set fso = CreateObject("Scripting.FileSystemObject")
    If Not fso.FolderExists(fontsFolder) Then
        MsgBox "مجلد الخطوط غير موجود: " & fontsFolder, vbExclamation
        Exit Sub
    End If
    
    ' تصفح الخطوط في المجلد
    Set folder = fso.GetFolder(fontsFolder)
    For Each file In folder.Files
        If LCase(Right(file.Name, 4)) = ".ttf" Or LCase(Right(file.Name, 4)) = ".otf" Then
            fontFile = file.Path
            fontName = GetFontName(fontFile)
            
            ' التحقق إذا كان الخط مثبتًا
            fontInstalled = IsFontInstalled(fontName)
            If Not fontInstalled Then
                If AddFontResource(fontFile) > 0 Then
                    ' تحديث النظام لإضافة الخط
                    SendMessage HWND_BROADCAST, WM_FONTCHANGE, 0, 0
                    MsgBox "تم تثبيت الخط: " & fontName, vbInformation
                Else
                    MsgBox "فشل في تثبيت الخط: " & fontName, vbExclamation
                End If
            End If
        End If
    Next file
    
    MsgBox "اكتمل التحقق من الخطوط.", vbInformation
End Sub

Function IsFontInstalled(fontName As String) As Boolean
    Dim regPath As String
    Dim objRegistry As Object
    
    On Error Resume Next
    regPath = "HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Fonts"
    Set objRegistry = CreateObject("WScript.Shell")
    IsFontInstalled = Not IsEmpty(objRegistry.RegRead(regPath & "\" & fontName & " (TrueType)"))
    On Error GoTo 0
End Function

Function GetFontName(fontFile As String) As String
    ' استرجاع اسم الملف بدون الامتداد
    GetFontName = CreateObject("Scripting.FileSystemObject").GetBaseName(fontFile)
End Function

 

[figo82eg]

شكرا للمساعدة ولكن اين يتم وضع الكود فى نموذج عند فتح القاعدة مثلا ام ماذا

[Eng.Qassim]

عن اذن اخي استاذ @ناقل

جربه مع اول نموذج يغتح عند فتح القاعدة وفي حدث عند التحميل تضع 

InstallFonts

 

[Moosak]

مشاركة مع الإخوة الأعزاء 🙂 

هذه طريقتي في تضمين الخطوط في البرنامج ..

1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات :

2 - في الموديول  كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات :

3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو    ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 

4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 

للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول .

الملف : Add Fonts.accdb