مالك2006 قام بنشر يونيو 18, 2023 مشاركة قام بنشر يونيو 18, 2023 (معدل) السلام عليكم اريد دالة تاكد من وجود خط مثبت في الويندوز ادا لم يجد الخط يفوم يتثبيث الخط اوتوماتيكيا تم تعديل يونيو 18, 2023 بواسطه مالك2006 رابط هذا التعليق شارك More sharing options...
AbuuAhmed قام بنشر يونيو 18, 2023 مشاركة قام بنشر يونيو 18, 2023 وجدت لك هذا الكود في النت: 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 لم أجربه، جربه واخبرنا. رابط هذا التعليق شارك More sharing options...
مالك2006 قام بنشر يونيو 19, 2023 الكاتب مشاركة قام بنشر يونيو 19, 2023 جربته لكن لم يشتغل رابط هذا التعليق شارك More sharing options...
Moosak قام بنشر يونيو 19, 2023 مشاركة قام بنشر يونيو 19, 2023 هذا كود لتنصيب الخطوط المضمنة في البرنامج إلى مجلد بجانب البرنامج وضيفة الكود هو استخراج الخطوط المخزنة في جدول الخطوط 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 رابط هذا التعليق شارك More sharing options...
مالك2006 قام بنشر يونيو 19, 2023 الكاتب مشاركة قام بنشر يونيو 19, 2023 بارك الله قيك اخي وبنسبة لموضوع جلب قيمة الى مربع نص من صفحة ويب هل فيه دالة اخرى تكون افضل رابط هذا التعليق شارك More sharing options...
الردود الموصى بها
من فضلك سجل دخول لتتمكن من التعليق
ستتمكن من اضافه تعليقات بعد التسجيل
سجل دخولك الان