figo82eg قام بنشر ديسمبر 21, 2024 قام بنشر ديسمبر 21, 2024 ارجو المساعدة حيث لدى قاعدة بيانات بجوارها ملف اسمه الخطوط بداخله الخطوط المستخدمة بالقاعدة. ما اريده هو عند فتح قاعدة البيانات يتم تثبيت جميع الخطوط داخل الملف بشكل تلقائى دون تدخل من اى مستخدم.
ناقل قام بنشر ديسمبر 21, 2024 قام بنشر ديسمبر 21, 2024 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 1
figo82eg قام بنشر ديسمبر 22, 2024 الكاتب قام بنشر ديسمبر 22, 2024 شكرا للمساعدة ولكن اين يتم وضع الكود فى نموذج عند فتح القاعدة مثلا ام ماذا
Eng.Qassim قام بنشر ديسمبر 22, 2024 قام بنشر ديسمبر 22, 2024 عن اذن اخي استاذ @ناقل جربه مع اول نموذج يغتح عند فتح القاعدة وفي حدث عند التحميل تضع InstallFonts
تمت الإجابة Moosak قام بنشر ديسمبر 22, 2024 تمت الإجابة قام بنشر ديسمبر 22, 2024 مشاركة مع الإخوة الأعزاء 🙂 هذه طريقتي في تضمين الخطوط في البرنامج .. 1- إرفاق الخطوط في البرنامج في جدول معد لذلك وبه حقل مرفقات : 2 - في الموديول كود يقوم باستخراج الخطوط ووضعها في مجلد بجانب قاعدة البيانات : 3 - يقوم الكود بتنصيب الخطوط تلقائيا بدون تدخل من المستخدم وذلك عن طريق الماكرو ( وبالمناسبة هو نفس الأمر الذي يستخرج الخطوط من الجدول ) 🙂 4- وبعدها ستجد أن الخطوط تعمل لديك بشكل جيد بدون مشاكل إن شاء الله 🙂 للتطبيق على برنامجك أنقل جميع العناصر لبرنامجك وغير الخطوط في الجدول . الملف : Add Fonts.accdb 5 1
Eng.Qassim قام بنشر ديسمبر 22, 2024 قام بنشر ديسمبر 22, 2024 فعلا خطوط جميلة عاشت الايادي استاذ @Moosak 1
hanan_ms قام بنشر ديسمبر 22, 2024 قام بنشر ديسمبر 22, 2024 بعد اذن استاذ @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 1
figo82eg قام بنشر ديسمبر 22, 2024 الكاتب قام بنشر ديسمبر 22, 2024 بارك الله فيكم أساتذتى الكرام وجعل الله علمكم فى ميزان حسناتكم 1
hanan_ms قام بنشر ديسمبر 28, 2024 قام بنشر ديسمبر 28, 2024 =============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن استاذي @ابو جودي ❤️🌹☕🌹 بعد اذن الاستاذ @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.