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

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

قام بنشر

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

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

قام بنشر
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

 

  • Like 1
قام بنشر

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

  • تمت الإجابة
قام بنشر

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

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

1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات :
image.png.2166dd5b8d3a951287d09cff3d7157f7.png
2 - في الموديول image.png.f4b77125d2bad14141f38b26904fe929.png كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات :
image.png.545f0027a763cf590bde52d8faa97d24.png
3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو  image.png.c9789a143788b76260bf3a4e37b024fc.png  ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 

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

image.png.9ce6dff30bdc1d9876f7b9d3baec553c.png

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

الملف : Add Fonts.accdb

  • Like 5
  • Thanks 1
قام بنشر

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

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

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

 

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

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

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

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

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

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

  • Like 1
  • Moosak changed the title to تثبيت الخطوط المستخدمة في البرنامج عند فتح قاعدة البيانات
قام بنشر

 =============================================( صور + مرفق + فيديو )

Update: :biggrin2:🌹

بعد اذن استاذي @ابو جودي ❤️🌹🌹

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

بعد اذن الاستاذ @Amr Ashraf ❤️🌹

 

1- اضافة 16 نوع من ملفات تثبت وتضاف عند الفتح وعند الفقد + ملفات التشغيلية + ملفات المضغوطة

ملاحظة:

-اذا كان .exe  غير الى .ex  بعد التنفيذ يغير الى exe. 

- اذا ملف فك الضغط

Zip يبدأ في حذف الملف ثم الفك التلقائي للملفات 

تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق

=============================================( مرفق + فيديو )

الدالة :

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 ExtractPath10                     As String
    Dim FontPath10                        As String
    Dim ExtractPath11                     As String
    Dim FontPath11                        As String
    Dim ExtractPath12                     As String
    Dim FontPath12                        As String
    Dim ExtractPath13                     As String
    Dim FontPath13                        As String
    Dim ExtractPath14                     As String
    Dim FontPath14                        As String
    Dim ExtractPath15                     As String
    Dim FontPath15                        As String
    Dim ExtractPath16                     As String
    Dim FontPath16                        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
    Dim File10                             As File
    Dim FontFolder10                       As Folder
    Dim File11                             As File
    Dim FontFolder11                       As Folder
    Dim File12                             As File
    Dim FontFolder12                       As Folder
    Dim File13                             As File
    Dim FontFolder13                       As Folder
    Dim File14                             As File
    Dim FontFolder14                       As Folder
    Dim File15                             As File
    Dim FontFolder15                       As Folder
    Dim File16                             As File
    Dim FontFolder16                       As Folder
    
'========================================================( Expoert Any File rar zip 7z tgz ...
     Dim sFolder, sFile, strDest, _
     zipPath, zipPwd, strFileName, _
     Operation, MyApp, strSource           As String
     Dim Rar_X_Zip                         As Integer
     Dim RarXZip                           As Object

    Set FSO = New Scripting.FileSystemObject
    
         On Error Resume Next
         '=================================( Delete Folder #File 16 for Export Zip or rar )
FSO.DeleteFolder CurrentProject.Path & "\All_InFile_One_Zip_Rar"

    
    ' ÅäÔÇÁ ãÌáÏ ááÎØæØ ÈÌÇäÈ ÞÇÚÏÉ ÇáÈíÇäÇÊ
'=========================================================( 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)
'=========================================================( File 10
    ExtractPath10 = CurrentProject.Path & "\File_word"
    If Not FSO.FolderExists(ExtractPath10) Then FSO.CreateFolder (ExtractPath10)
'=========================================================( File 11
    ExtractPath11 = CurrentProject.Path & "\File_Excel"
    If Not FSO.FolderExists(ExtractPath11) Then FSO.CreateFolder (ExtractPath11)
'=========================================================( File 12
    ExtractPath12 = CurrentProject.Path & "\Book"
    If Not FSO.FolderExists(ExtractPath12) Then FSO.CreateFolder (ExtractPath12)
'=========================================================( File 13
    ExtractPath13 = CurrentProject.Path & "\File_PowerPoint"
    If Not FSO.FolderExists(ExtractPath13) Then FSO.CreateFolder (ExtractPath13)
'=========================================================( File 14
    ExtractPath14 = CurrentProject.Path & "\File_Text"
    If Not FSO.FolderExists(ExtractPath14) Then FSO.CreateFolder (ExtractPath14)
'=========================================================( File 15
    ExtractPath15 = CurrentProject.Path & "\File_Code"
    If Not FSO.FolderExists(ExtractPath15) Then FSO.CreateFolder (ExtractPath15)
'=========================================================( File 16
    ExtractPath16 = CurrentProject.Path & "\All_InFile_One_Zip_Rar"
    If Not FSO.FolderExists(ExtractPath16) Then FSO.CreateFolder (ExtractPath16)
    
    
    ' ÇÓÊÎÑÇÌ ÌãíÚ ÇáÎØæØ ãä ÇáÌÏæá Åáì ãÌáÏ ÇáÎØæØ
'==========================================================( 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", "File_Executable_ExE", ExtractPath8
'==========================================================( 9
    ExtractAllAttachments "FontsT", "IMG_Report", ExtractPath9
 '==========================================================( 10
    ExtractAllAttachments "FontsT", "File_Word", ExtractPath10
'==========================================================( 11
    ExtractAllAttachments "FontsT", "File_Excel", ExtractPath11
'==========================================================( 12
    ExtractAllAttachments "FontsT", "Book", ExtractPath12
'==========================================================( 13
    ExtractAllAttachments "FontsT", "File_PowerPoint", ExtractPath13
'==========================================================( 14
    ExtractAllAttachments "FontsT", "File_Text", ExtractPath14
'==========================================================( 15
    ExtractAllAttachments "FontsT", "File_Code", ExtractPath15
'==========================================================( 16
    ExtractAllAttachments "FontsT", "All_InFile_One_Zip_Rar", ExtractPath16
   
'==========================================================( Chack File with Type For Past File
'==========================================================( 1 Font
    Set FontFolder = FSO.GetFolder(ExtractPath)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    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 Img Icon_Button
    Set FontFolder2 = FSO.GetFolder(ExtractPath2)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File2 In FontFolder2.Files
               If Right(File2.Name, 3) = "jpg" Or Right(File2.Name, 3) = "jpeg" _
        Or Right(File2.Name, 3) = "png" Or Right(File2.Name, 3) = "gif" _
        Or Right(File2.Name, 3) = "bmp" Or Right(File2.Name, 3) = "tiff" _
        Or Right(File2.Name, 3) = "tif" Or Right(File2.Name, 3) = "ico" _
        Or Right(File2.Name, 3) = "webp" Or Right(File2.Name, 3) = "heif" _
        Or Right(File2.Name, 3) = "heic" Then

            FontPath2 = ExtractPath2 & "\" & File2.Name
            Debug.Print vbCr & FontPath2
            AddOneFont FontPath2
            Debug.Print File2.Name, "Added"
        End If
    Next
'==========================================================( 3 IMG Icon_ Msgbox
    Set FontFolder3 = FSO.GetFolder(ExtractPath3)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File3 In FontFolder3.Files
               If Right(File3.Name, 3) = "jpg" Or Right(File3.Name, 3) = "jpeg" _
        Or Right(File3.Name, 3) = "png" Or Right(File3.Name, 3) = "gif" _
        Or Right(File3.Name, 3) = "bmp" Or Right(File3.Name, 3) = "tiff" _
        Or Right(File3.Name, 3) = "tif" Or Right(File3.Name, 3) = "ico" _
        Or Right(File3.Name, 3) = "webp" Or Right(File3.Name, 3) = "heif" _
        Or Right(File3.Name, 3) = "heic" Then

            FontPath = ExtractPath3 & "\" & File3.Name
            Debug.Print vbCr & FontPath3
            AddOneFont FontPath3
            Debug.Print File3.Name, "Added"
        End If
    Next
'==========================================================( 4 Sound
 Set FontFolder4 = FSO.GetFolder(ExtractPath4)
 
          On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File4 In FontFolder4.Files
        If Right(File4.Name, 3) = "mp3" Or Right(File4.Name, 3) = "wav" _
        Or Right(File4.Name, 3) = "ogg" Or Right(File4.Name, 4) = "flac" _
        Or Right(File4.Name, 3) = "aac" Or Right(File4.Name, 3) = "m4a" _
        Or Right(File4.Name, 3) = "wma" Or Right(File4.Name, 4) = "alac" _
        Or Right(File4.Name, 4) = "opus" Or Right(File4.Name, 4) = "aiff" Then
        
            FontPath = ExtractPath4 & "\" & File4.Name
            Debug.Print vbCr & FontPath4
            AddOneFont FontPath4
            Debug.Print File4.Name, "Added"
        End If
    Next
'==========================================================( 5 IMGE Wallpaper
    Set FontFolder5 = FSO.GetFolder(ExtractPath5)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder5.Files
        If Right(File5.Name, 3) = "jpg" Or Right(File5.Name, 3) = "jpeg" _
        Or Right(File5.Name, 3) = "png" Or Right(File5.Name, 3) = "gif" _
        Or Right(File5.Name, 3) = "bmp" Or Right(File5.Name, 3) = "tiff" _
        Or Right(File5.Name, 3) = "tif" Or Right(File5.Name, 3) = "ico" _
        Or Right(File5.Name, 3) = "webp" Or Right(File5.Name, 3) = "heif" _
        Or Right(File5.Name, 3) = "heic" Then
        
            FontPath = ExtractPath5 & "\" & File5.Name
            Debug.Print vbCr & FontPath5
            AddOneFont FontPath5
            Debug.Print File5.Name, "Added"
        End If
    Next
'==========================================================( 6 video
    Set FontFolder6 = FSO.GetFolder(ExtractPath6)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File6 In FontFolder6.Files
        If Right(File6.Name, 3) = "mp4" Or Right(File6.Name, 3) = "avi" _
        Or Right(File6.Name, 3) = "mov" Or Right(File6.Name, 3) = "mkv" _
        Or Right(File6.Name, 3) = "flv" Or Right(File6.Name, 3) = "wmv" _
        Or Right(File6.Name, 3) = "webm" Or Right(File6.Name, 3) = "mpeg" _
        Or Right(File6.Name, 3) = "mpg" Or Right(File6.Name, 3) = "3gp" _
        Or Right(File6.Name, 3) = "ts" Then
            FontPath6 = ExtractPath6 & "\" & File6.Name
            Debug.Print vbCr & FontPath6
            AddOneFont FontPath6
            Debug.Print File6.Name, "Added"
        End If
    Next
'==========================================================( 7 DB Ms Access
    Set FontFolder7 = FSO.GetFolder(ExtractPath7)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File7 In FontFolder7.Files
        If Right(File7.Name, 3) = "accda" Or Right(File7.Name, 3) = "accdb" _
        Or Right(File7.Name, 3) = "accde" Or Right(File7.Name, 3) = "accdr" _
        Or Right(File7.Name, 3) = "accdt" Or Right(File7.Name, 3) = "accdw" _
        Or Right(File7.Name, 3) = "mda" Or Right(File7.Name, 3) = "mdb" _
        Or Right(File7.Name, 3) = "mde" Or Right(File7.Name, 3) = "mdf" _
        Or Right(File7.Name, 3) = "mdw" Then
            FontPath = ExtractPath7 & "\" & File7.Name
            Debug.Print vbCr & FontPath7
            AddOneFont FontPath7
            Debug.Print File7.Name, "Added"
        End If
    Next
'==========================================================( 8 Run Applciation
    Set FontFolder8 = FSO.GetFolder(ExtractPath8)
    
     On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder8.Files
        If Right(File8.Name, 3) = "exe" Or Right(File8.Name, 3) = "bat" _
         Or Right(File8.Name, 3) = "cmd" Or Right(File8.Name, 3) = "msi" _
         Or Right(File8.Name, 3) = "apk" Or Right(File8.Name, 3) = "app" _
         Or Right(File8.Name, 3) = "dmg" Or Right(File8.Name, 3) = "jar" Then
            FontPath8 = ExtractPath8 & "\" & File8.Name
            Debug.Print vbCr & FontPath8
            AddOneFont FontPath8
            Debug.Print File8.Name, "Added"
        End If
           If FontPath8 = ExtractPath8 & "\" & File8.Name = ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.ex" Then
   '=========================================================()
Set RarXZip = CreateObject("scripting.filesystemobject")
         '==========================================(Chang Name )
 RarXZip.CopyFile (ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.ex"), (ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.exe")
End If

    Next
    Kill (ExtractPath8 & "\" & "Zip-UnZip By Amr Ashraf.ex")
    
'==========================================================( 9 IMg_Report
    Set FontFolder9 = FSO.GetFolder(ExtractPath9)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder9.Files
                If Right(File9.Name, 3) = "jpg" Or Right(File9.Name, 3) = "jpeg" _
        Or Right(File9.Name, 3) = "png" Or Right(File9.Name, 3) = "gif" _
        Or Right(File9.Name, 3) = "bmp" Or Right(File9.Name, 3) = "tiff" _
        Or Right(File9.Name, 3) = "tif" Or Right(File9.Name, 3) = "ico" _
        Or Right(File9.Name, 3) = "webp" Or Right(File9.Name, 3) = "heif" _
        Or Right(File9.Name, 3) = "heic" Then

            FontPath9 = ExtractPath9 & "\" & File9.Name
            Debug.Print vbCr & FontPath9
            AddOneFont FontPath9
            Debug.Print File9.Name, "Added"
        End If
    Next
'==========================================================( 10 File_word
    Set FontFolder10 = FSO.GetFolder(ExtractPath10)
    
          On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder10.Files
        If Right(File10.Name, 4) = "docx" Or Right(File10.Name, 3) = "doc" _
        Or Right(File10.Name, 4) = "docm" Or Right(File10.Name, 4) = "dotx" _
        Or Right(File10.Name, 4) = "dotm" Or Right(File10.Name, 3) = "rtf" _
        Or Right(File10.Name, 3) = "odt" Then

            FontPath10 = ExtractPath10 & "\" & File10.Name
            Debug.Print vbCr & FontPath10
            AddOneFont FontPath10
            Debug.Print File10.Name, "Added"
        End If
    Next
'==========================================================( 11 File_Excel
    Set FontFolder11 = FSO.GetFolder(ExtractPath11)
    
          On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder11.Files
                If Right(File11.Name, 4) = "xlsx" Or Right(File11.Name, 3) = "xls" _
        Or Right(File11.Name, 4) = "xlsm" Or Right(File11.Name, 4) = "xlsb" _
        Or Right(File11.Name, 4) = "xltx" Or Right(File11.Name, 4) = "xltm" Then

            FontPath11 = ExtractPath11 & "\" & File11.Name
            Debug.Print vbCr & FontPath11
            AddOneFont FontPath11
            Debug.Print File11.Name, "Added"
        End If
    Next
'==========================================================( 12 Book
    Set FontFolder12 = FSO.GetFolder(ExtractPath12)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder12.Files
                If Right(File12.Name, 3) = "pdf" Or Right(File12.Name, 3) = "Html" _
        Or Right(File12.Name, 3) = "Cs3" Or Right(File12.Name, 3) = "Cs6" _
        Or Right(File12.Name, 3) = "jpg" Or Right(File12.Name, 3) = "png" _
        Or Right(File12.Name, 3) = "C4D" Then

            FontPath12 = ExtractPath12 & "\" & File12.Name
            Debug.Print vbCr & FontPath12
            AddOneFont FontPath12
            Debug.Print File12.Name, "Added"
        End If
    Next
'==========================================================( 13 File_PowerPoint
    Set FontFolder13 = FSO.GetFolder(ExtractPath13)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder13.Files
                If Right(File13.Name, 3) = "pptx" Or Right(File13.Name, 3) = "ppt" _
        Or Right(File13.Name, 3) = "ppsx" Or Right(File13.Name, 3) = "pps" _
        Or Right(File13.Name, 3) = "pptm" Or Right(File13.Name, 3) = "potx" _
        Or Right(File13.Name, 3) = "potm" Then

            FontPath13 = ExtractPath13 & "\" & File13.Name
            Debug.Print vbCr & FontPath13
            AddOneFont FontPath13
            Debug.Print File13.Name, "Added"
        End If
    Next
'==========================================================( 14 File_Text
    Set FontFolder14 = FSO.GetFolder(ExtractPath14)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder14.Files
                If Right(File14.Name, 3) = "txt" Or Right(File14.Name, 3) = "csv" _
        Or Right(File14.Name, 3) = "log" Or Right(File14.Name, 3) = "md" _
        Or Right(File14.Name, 3) = "rtf" Then

            FontPath14 = ExtractPath14 & "\" & File14.Name
            Debug.Print vbCr & FontPath14
            AddOneFont FontPath14
            Debug.Print File14.Name, "Added"
        End If
    Next
'==========================================================( 15 File_Code
    Set FontFolder15 = FSO.GetFolder(ExtractPath15)
    
         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder15.Files
                If Right(File15.Name, 3) = "html" Or Right(File15.Name, 3) = "css" _
        Or Right(File15.Name, 3) = "js" Or Right(File15.Name, 3) = "php" _
        Or Right(File15.Name, 3) = "py" Or Right(File15.Name, 3) = "java" _
        Or Right(File15.Name, 3) = "cpp" Or Right(File15.Name, 3) = "c" _
        Or Right(File15.Name, 3) = "rb" Or Right(File15.Name, 3) = "swift" _
        Or Right(File15.Name, 3) = "go" Or Right(File15.Name, 3) = "ts" Then

            FontPath15 = ExtractPath15 & "\" & File15.Name
            Debug.Print vbCr & FontPath15
            AddOneFont FontPath15
            Debug.Print File15.Name, "Added"
        End If
    Next
'==========================================================( 16 All_InFile_One_Zip_Rar
    Set FontFolder16 = FSO.GetFolder(ExtractPath16)
    
MyApp = Application.CurrentProject.Path & "\ExE\Zip-UnZip By Amr Ashraf.exe"

         On Error Resume Next '==================== ( IsNull_And_Next Raed
    For Each File In FontFolder16.Files
   On Error Resume Next
            '   If Right(File16.Name, 3) = "zip" Then Or Right(File16.Name, 3) = "rar" _
    '    Or Right(File16.Name, 3) = "7z" Or Right(File16.Name, 3) = "tar" _
     '   Or Right(File16.Name, 3) = "gz" Or Right(File16.Name, 3) = "tar.gz" _
      '  Or Right(File16.Name, 3) = "tgz" Or Right(File16.Name, 3) = "xz" _
       ' Or Right(File16.Name, 3) = "bz2" Then

            FontPath16 = ExtractPath16 & "\" & File16.Name
            Debug.Print vbCr & FontPath16
            AddOneFont FontPath16
            Debug.Print File16.Name, "Added"
    '    End If
    Next

'=================================================================()
                '=================================================( 16 Open Export Any File Rar Zip 7z tgz ...
                For Rar_X_Zip = 1 To 1 ' who match rar file or zip
Operation = "UnZipFile"
strSource = ExtractPath16 & "\" & "Help_Or_Action_Concted_File_FTP.zip"
zipPwd = ""
strDest = ExtractPath16 & "\\"
        
Debug.Print strSource
Debug.Print strDest
        
Call Shell("""" & MyApp & """  """ & Operation & """ """ & strSource & """ """ & strDest & """ """ & zipPwd & """", 1)

     Next
Pause (1)
Kill (strSource)
    Set FSO = Nothing
End Function

 

V-1-6 Add Folder_with _File_ SyS_ Ms_Access.rar

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