تنصيب خط font مرافق لقاعدة البيانات

[مالك2006]

السلام عليكم

اريد دالة تاكد من وجود خط مثبت في الويندوز

ادا لم يجد الخط يفوم يتثبيث الخط اوتوماتيكيا

تم تعديل يونيو 18, 2023 بواسطه مالك2006

[AbuuAhmed]

وجدت لك هذا الكود في النت:
 

Private Declare Function AddFontResource Lib "gdi32.dll" Alias "AddFontResourceA" ( _
    ByVal lpFileName As String) As Long

Sub Test()
    Dim Result As Long
  
    Result = AddFontResource(CurrentProject.Path & "\Fonts\Fontname")
    MsgBox Result & " fonts added"
End Sub

لم أجربه، جربه واخبرنا.

[مالك2006]

جربته لكن لم يشتغل

 

[Moosak]

هذا كود لتنصيب الخطوط المضمنة في البرنامج إلى مجلد بجانب البرنامج

وضيفة الكود هو استخراج الخطوط المخزنة في جدول الخطوط FontsT إلى مجلد Fonts بجانب قاعدة البيانات ثم يضيفها لبرنامج الأكسس بدون تنصيبها على الجهاز .. وذلك لكي تعمل معك الخطوط التي صممت بها البرنامج.

لكي يعمل الكود معك :
1- قم بإنشاء جدول في برنامجك واسمه FontsT وبه حقل مرفقات اسمه Fonts ويتم تخزين الخطوط داخله 
2 - قم بإضافة المكتبة التالية : Microsoft Scripting Runtime
3 - قم بمناداة الدالة التي تقوم بالمهمة AddFonts() من أي مكان تريده ( هنا أنا وضعتها في ماكرو Autoexec)

Option Compare Database
Option Explicit

'Designed By: Moosa AlKalbani

Private Declare PtrSafe Function AddFontResource Lib "gdi32.dll" Alias "AddFontResourceA" ( _
    ByVal lpFileName As String) As Long


Public Function AddFonts()

    Dim ExtractPath As String
    Dim FontPath As String
    Dim FSO As Object
    Dim File As File
    Dim FontFolder As Folder
    
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    ' إنشاء مجلد للخطوط بجانب قاعدة البيانات
    ExtractPath = CurrentProject.Path & "\fonts"
    If Not FSO.FolderExists(ExtractPath) Then FSO.CreateFolder (ExtractPath)
    
    ' استخراج جميع الخطوط من الجدول إلى مجلد الخطوط
    ExtractAllAttachments "FontsT", "Fonts", ExtractPath
    
    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
    Set FSO = Nothing
End Function


Public Function AddOneFont(Font_Name_Path As String)

  Dim result As Long
  
  result = AddFontResource(Font_Name_Path)
'  MsgBox result & " fonts added"
  
End Function

Public Function ExtractAllAttachments(ByVal TableName As String, ByVal AttchmentColumnName As String, ByVal ExtractToFolder As String)

' TableName : اسم الجدول
' AttchmentColumnName : اسم حقل المرفقات
' ExtractToFolder: المكان المراد استخراج الملفات إليه مثال : "C:\ExtractHere"

    Dim RsMainrecords As dao.Recordset2
    Dim RsAttachments As dao.Recordset2
    
    Set RsMainrecords = CurrentDb.OpenRecordset("select " & AttchmentColumnName & _
                                                " from " & TableName & _
                                                " where " & AttchmentColumnName & ".FileName is not Null")
    Do Until RsMainrecords.EOF
        
        Set RsAttachments = RsMainrecords.Fields(AttchmentColumnName).Value
        
        Do Until RsAttachments.EOF
            Dim OutputFileName As String
            
            OutputFileName = RsAttachments.Fields("FileName").Value
            OutputFileName = ExtractToFolder & "\" & OutputFileName
             
                If Len(Dir(OutputFileName, vbDirectory)) = 0 Then
                    On Error Resume Next
                    Debug.Print OutputFileName
                    RsAttachments.Fields("FileData").SaveToFile OutputFileName
                End If
            RsAttachments.MoveNext
        Loop
        
        RsAttachments.Close
        RsMainrecords.MoveNext
    Loop
    
    RsMainrecords.Close
    
    Set RsMainrecords = Nothing
    Set RsAttachments = Nothing

End Function

ويمكنك استدعائه عن طريق مناداة الدالة باسمها :

AddFonts()

مثال :

Add Fonts.accdb

[مالك2006]

بارك الله قيك اخي

وبنسبة لموضوع جلب قيمة الى مربع نص من صفحة ويب

هل فيه دالة اخرى تكون افضل