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

[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

[Eng.Qassim]

فعلا خطوط جميلة

عاشت الايادي استاذ @Moosak

[hanan_ms]

بعد اذن استاذ @Moosak ❤️🌹🌹

عدلة على مرفقك وزد ملفات ثانية بنفس الدالة 

شكرا على المرفق 

 

مع ضبط حجم النافذه لا يقل ويصغر فقط يتوسع ويكبر الى كامل الشاشة 

يمكن كان الحدث قبل التحديث 

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

ينفع اذا فقد الملف اعادة احضار الكل وعند التشغيل

تقدر تضيف ملف  ضغط رار فيه توزيعة ملفات = استخراج ثم فك الضغط كملفات على سبيل المثال 

PDF ( Book About Help )

له جدول يتصل بملفات جنب القاعده

Public Function AddFonts()
'======================================================( File Add
    Dim ExtractPath                       As String
    Dim FontPath                          As String
    Dim ExtractPath2                      As String
    Dim FontPath2                         As String
    Dim ExtractPath3                      As String
    Dim FontPath3                         As String
    Dim ExtractPath4                      As String
    Dim FontPath4                         As String
    Dim ExtractPath5                      As String
    Dim FontPath5                         As String
    Dim ExtractPath6                      As String
    Dim FontPath6                         As String
    Dim ExtractPath7                      As String
    Dim FontPath7                         As String
    Dim ExtractPath8                      As String
    Dim FontPath8                         As String
    Dim ExtractPath9                      As String
    Dim FontPath9                         As String
    
    Dim FSO                               As Scripting.FileSystemObject
'======================================================( Exprt Fil In File Add
    Dim File                               As File
    Dim FontFolder                         As Folder
    Dim File2                              As File
    Dim FontFolder2                        As Folder
    Dim File3                              As File
    Dim FontFolder3                        As Folder
    Dim File4                              As File
    Dim FontFolder4                        As Folder
    Dim File5                              As File
    Dim FontFolder5                        As Folder
    Dim File6                              As File
    Dim FontFolder6                        As Folder
    Dim File7                              As File
    Dim FontFolder7                        As Folder
    Dim File8                              As File
    Dim FontFolder8                        As Folder
    Dim File9                              As File
    Dim FontFolder9                        As Folder

    
    Set FSO = New Scripting.FileSystemObject
    
    ' إنشاء مجلد للخطوط بجانب قاعدة البيانات
'=========================================================( File 1
    ExtractPath = CurrentProject.Path & "\fonts"
    If Not FSO.FolderExists(ExtractPath) Then FSO.CreateFolder (ExtractPath)
'=========================================================( File 2
    ExtractPath2 = CurrentProject.Path & "\Icon_Button"
    If Not FSO.FolderExists(ExtractPath2) Then FSO.CreateFolder (ExtractPath2)
'=========================================================( File 3
    ExtractPath3 = CurrentProject.Path & "\Icon_Msgbox"
    If Not FSO.FolderExists(ExtractPath3) Then FSO.CreateFolder (ExtractPath3)
'=========================================================( File 4
    ExtractPath4 = CurrentProject.Path & "\Sound"
    If Not FSO.FolderExists(ExtractPath4) Then FSO.CreateFolder (ExtractPath4)
'=========================================================( File 5
    ExtractPath5 = CurrentProject.Path & "\Wallpaper"
    If Not FSO.FolderExists(ExtractPath5) Then FSO.CreateFolder (ExtractPath5)
'=========================================================( File 6
    ExtractPath6 = CurrentProject.Path & "\Video"
    If Not FSO.FolderExists(ExtractPath6) Then FSO.CreateFolder (ExtractPath6)
'=========================================================( File 7
    ExtractPath7 = CurrentProject.Path & "\db_BE"
    If Not FSO.FolderExists(ExtractPath7) Then FSO.CreateFolder (ExtractPath7)
'=========================================================( File 8
    ExtractPath8 = CurrentProject.Path & "\ExE"
    If Not FSO.FolderExists(ExtractPath8) Then FSO.CreateFolder (ExtractPath8)
'=========================================================( File 9
    ExtractPath9 = CurrentProject.Path & "\IMG_Report"
    If Not FSO.FolderExists(ExtractPath9) Then FSO.CreateFolder (ExtractPath9)
    
    ' استخراج جميع الخطوط من الجدول إلى مجلد الخطوط
'==========================================================( Form Name_tablet,File ,past File
'==========================================================( 1
    ExtractAllAttachments "FontsT", "Fonts", ExtractPath
'==========================================================( 2
    ExtractAllAttachments "FontsT", "Icon_Button", ExtractPath2
'==========================================================( 3
    ExtractAllAttachments "FontsT", "Icon_Msgbox", ExtractPath3
'==========================================================( 4
    ExtractAllAttachments "FontsT", "Sound", ExtractPath4
'==========================================================( 5
    ExtractAllAttachments "FontsT", "Wallpaper", ExtractPath5
'==========================================================( 6
    ExtractAllAttachments "FontsT", "Video", ExtractPath6
'==========================================================( 7
    ExtractAllAttachments "FontsT", "db_BE", ExtractPath7
'==========================================================( 8
    ExtractAllAttachments "FontsT", "ExE", ExtractPath8
'==========================================================( 9
    ExtractAllAttachments "FontsT", "IMG_Report", ExtractPath9
    
'==========================================================( Chack File with Type For Past File
'==========================================================( 1
    Set FontFolder = FSO.GetFolder(ExtractPath)
    
    For Each File In FontFolder.Files
        If Right(File.Name, 3) = "TTF" Or Right(File.Name, 3) = "OTF" Then
            FontPath = ExtractPath & "\" & File.Name
            Debug.Print vbCr & FontPath
            AddOneFont FontPath
            Debug.Print File.Name, "Added"
        End If
    Next
    
'==========================================================( 2
    Set FontFolder2 = FSO.GetFolder(ExtractPath2)
    
    For Each File2 In FontFolder2.Files
        If Right(File2.Name, 3) = "TTF" Or Right(File2.Name, 3) = "OTF" Then
            FontPath2 = ExtractPath2 & "\" & File2.Name
            Debug.Print vbCr & FontPath2
            AddOneFont FontPath2
            Debug.Print File2.Name, "Added"
        End If
    Next
'==========================================================( 3
    Set FontFolder3 = FSO.GetFolder(ExtractPath3)
    
    For Each File3 In FontFolder3.Files
        If Right(File3.Name, 3) = "TTF" Or Right(File3.Name, 3) = "OTF" Then
            FontPath = ExtractPath3 & "\" & File3.Name
            Debug.Print vbCr & FontPath3
            AddOneFont FontPath3
            Debug.Print File3.Name, "Added"
        End If
    Next
'==========================================================( 4
    Set FontFolder4 = FSO.GetFolder(ExtractPath4)
    
    For Each File4 In FontFolder4.Files
        If Right(File4.Name, 3) = "TTF" Or Right(File4.Name, 3) = "OTF" Then
            FontPath = ExtractPath4 & "\" & File4.Name
            Debug.Print vbCr & FontPath4
            AddOneFont FontPath4
            Debug.Print File4.Name, "Added"
        End If
    Next
'==========================================================( 5
    Set FontFolder5 = FSO.GetFolder(ExtractPath5)
    
    For Each File In FontFolder5.Files
        If Right(File5.Name, 3) = "TTF" Or Right(File5.Name, 3) = "OTF" Then
            FontPath = ExtractPath5 & "\" & File5.Name
            Debug.Print vbCr & FontPath5
            AddOneFont FontPath5
            Debug.Print File5.Name, "Added"
        End If
    Next
'==========================================================( 6
    Set FontFolder6 = FSO.GetFolder(ExtractPath6)
    
    For Each File6 In FontFolder6.Files
        If Right(File6.Name, 3) = "TTF" Or Right(File6.Name, 3) = "OTF" Then
            FontPath6 = ExtractPath6 & "\" & File6.Name
            Debug.Print vbCr & FontPath6
            AddOneFont FontPath6
            Debug.Print File6.Name, "Added"
        End If
    Next
'==========================================================( 7
    Set FontFolder7 = FSO.GetFolder(ExtractPath7)
    
    For Each File7 In FontFolder7.Files
        If Right(File7.Name, 3) = "TTF" Or Right(File7.Name, 3) = "OTF" Then
            FontPath = ExtractPath7 & "\" & File7.Name
            Debug.Print vbCr & FontPath7
            AddOneFont FontPath7
            Debug.Print File7.Name, "Added"
        End If
    Next
'==========================================================( 8
    Set FontFolder8 = FSO.GetFolder(ExtractPath8)
    
    For Each File In FontFolder8.Files
        If Right(File8.Name, 3) = "TTF" Or Right(File8.Name, 3) = "OTF" Then
            FontPath8 = ExtractPath8 & "\" & File8.Name
            Debug.Print vbCr & FontPath8
            AddOneFont FontPath8
            Debug.Print File8.Name, "Added"
        End If
    Next
'==========================================================( 9
    Set FontFolder9 = FSO.GetFolder(ExtractPath9)
    
    For Each File In FontFolder9.Files
        If Right(File9.Name, 3) = "TTF" Or Right(File9.Name, 3) = "OTF" Then
            FontPath9 = ExtractPath9 & "\" & File9.Name
            Debug.Print vbCr & FontPath9
            AddOneFont FontPath9
            Debug.Print File9.Name, "Added"
        End If
    Next

    Set FSO = Nothing
End Function

 

 

SeT_File_SyS_Add_Pcage_And_Font_Ms_Access.rar

[figo82eg]

بارك الله فيكم أساتذتى الكرام وجعل الله علمكم فى ميزان حسناتكم