اذهب الي المحتوي
أوفيسنا
بحث مخصص من جوجل فى أوفيسنا
Custom Search

الردود الموصى بها

قام بنشر (معدل)

السلام عليكم

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

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

تم تعديل بواسطه مالك2006
قام بنشر

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

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

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

قام بنشر

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

وضيفة الكود هو استخراج الخطوط المخزنة في جدول الخطوط 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

قام بنشر

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

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

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

 

Join the conversation

You can post now and register later. If you have an account, sign in now to post with your account.

زائر
اضف رد علي هذا الموضوع....

×   Pasted as rich text.   Paste as plain text instead

  Only 75 emoji are allowed.

×   Your link has been automatically embedded.   Display as a link instead

×   Your previous content has been restored.   Clear editor

×   You cannot paste images directly. Upload or insert images from URL.

  • تصفح هذا الموضوع مؤخراً   0 اعضاء متواجدين الان

    • لايوجد اعضاء مسجلون يتصفحون هذه الصفحه
×
×
  • اضف...

Important Information