نجوم المشاركات

السلام عليكم ورحمة الله محاولة في الملف المرفق... Track.xlsb

شكرا اخي موسى .. الملف رائع وجميل .. وأجر نقلك على الله واعتب على اخونا السائل في تجهيزه لمثال سيء في التسميات رغم انه من الاعضاء المتميزين وغالبا امثلته رصينة بالنسبة لادخال المعايير هذه محاولة مني UsingTransactionNoClass_2.rar

السلام عليكم بالنسبة للشهر والسنة يمكنك الاخنيار من القائمة ووكلما اضفت شهرا جديدا يتم اظافته تلقائيا الى القائمة ويتم احضاره الى التقرير جرل الملف وان كان هناك ملاحظات اذكرها attedance report (1).xlsb

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

جزاكم الله خيرا

20244شيت مدرستى الصف السادس.xlsb

وعليكم السلام ورحمة الله وبركاته جرب الملف حيث يتم انشاء مجلد في نفس مسار الملف 20244شيت مدرستى الصف السادس.xls

كل ترحيل عبارة عن مجموعة من السجلات .. يتم لاحقا حذفها جملة بزر بامر واحد .. راجع مشاركتي السابقة جيدا من اجل هذا كتبت رؤيتي حول العملية .. حول نقطتين او اجرائين في فكرتك الأصلية : 1- المقارنة بين السجلات في قاعدتين متباعدتين 1- الحذف الآلي

وعليكم السلام ورحمة الله وبركاته شاهد المرفق حدد اي المعادلتين المطلوبة في العمود V او X Track.xlsb

عليكم السلام .. اهلا ابا حاتم رأيي ان تستغني عن عملية البحث هذه .. لتجنب بعض المحاذير التي قد تحدث والطريقة الآمنة ان تعمل استعلام في البرنامج الأول يظهر السجلات التي مضى عليها اكثر من شهر .. لكي تلحقها بالقاعدة الثانية . ثم تحذفها اما عملية الحذف فهي ايضا خطيرة لأننا نضع في اعتبارنا جميع الاحتمالات ( قد لا تصل السجلات الى القاعدة الثانية لأسباب عدة يعرفها غالب المبرمجين ) فأرى ان تكون عملية الحذف وهمية لفترة محددة ( من اجل زيادة الأمان) وتتم لاحقا على فترات الحذف الوهمي هي اضافة حقل نعم/لا للتحكم في ظهور السجلات من عدمه

هل عشان اتعمله واعمل فروم وصفحات .لازم اكون خبرة فى البرمجة لان انا ليس لدى اى خبرة فى البرمجة كيف اتعمله اى فديوهات اشاهدها شكرا جزيلا

ما تركت لصاحب الموضوع ولاااااا ذرة أمل

اهلا بك اخي هشام بالنسبة الى اجابة سوالك , الاجابة يمكن ان تكون طويلة نوعا ما , كيف ؟؟ لكي تعمل فورم, هذا = تطبيقات سطح المكتب =تعليم VBA لكی تتعامل مع الاكسس ، او C# لكی تتعامل مع Visual Stodio لكي تعمل صفحات, هذا = تعليم لغة Html ,CSS,JavaScript ,طبعا كلها تحتاج الى معرفة برمجية ناهیك عن ملایین المشاكل التی ستواجهها عند تكوین مشروع ، او برنامج متكامل ، وانا هنا لا اخوفك ، ولكن لتكون لدیك اللیاقە للاستمراریە --------------------------------------------- لنوضح اكثر : كل برنامج او صفحة من صفحات النت مكونة من : 1-Front End بمعنى الواجهات التي تشاهدها اثناء العمل على البرنامج (اغلق , افتح , الذهاب الى تنفيذ عمل او ارسال رسالة او عملية حفظ او صور او الخ) ,و كلها تحتاج ال تعليم لغة Html ,CSS,JavaScript 2-BackEnd : الخلف الذی لا تشاهدە ، وتتم فیها كل العملیات مثل (فلترة ,بحث , تحقيق من رقم سري و باسورد , استعلام عن معلومات معينة والخ ) وهنا تحتاج الى معرفة ببرنامج قواعد البيانات وهي كثيرة -الاكسس هنا يجمع بين الاثنين,, ولذلك هو سهل التعامل في بيئته!! ولكن صعب في بيئات مختلفة!! مثلا (انشات برنامج و اعطيته الى شخصين الاول ويندوز 32 و الثاني 46 هنا مشكلة ,, الاول دقة شاشته 14 و الثاني 17 , و شاشتك 15 هنا مشكلة اخرى , ولغة ويندوز الاول انجليزي و الثاني بنغالي ,هنا مشكلة اخرى , و الى اخره من المشاكل التي لاحصر لها و اخيرا يجيك بعد عدة سنوات حجم القاعدة ) انت لن تنتهي من هذه المشاكل وستبقى في هذه الدوامة , انا هنا ارشدك الى الطريق الصحيح لتبدا به , لا لتنخدع بجمال الفورم و تكتيكاته المزيفة (هذه كلها خزعبلات) ارجوا ان وفقت في ايصال القليل من المعلومات الى حضرتك و بالتوفيق الكامل لك

جزاك الله كل الخير الأخ والأستاذ الفاضل وربي يبارك لك في جميع أمورك هذا هو المطلوب بالضبط فقط انا قمت بكتابة LEFT مكان INNER حتى يظهر جميع الموظفين في جدول tbl_evaluation وهذا عند الضغط على زر إدارج ، حتى وإن كان الموظفين غير موجودين في جدول : tbl_poste_superieur ألف شكر وامتنان أخي

شكر وتقدير من اخيك

اخي @هشام جمال الدين الملف المرفق عبارة عن شاشة دخول تتضمن تخويل صلاحية الدخول لاوراق معينة لمستخدم معين عبر تحديد دالك في ورقة صلاحيات باظافة عبارة نعم أو لا في الجدول التالي يمكنك اظافة ملفات أخرى للملف عادي سيتم تحديث أسمائها تلقائيا في عمود A بداية من الصف 6 دون مشاكل بما أنك حدفت جميع الأوراق السابقة والاحتفاظ فقط بالوقة 16 يكفي فقط تعديل الأكواد الخاصة بالدخول لأوراق العمل (مسميات الأوراق) لتفادي ظهور رسالة الخطأ معك أو مراجعة الموضوع الأصلي للتوضيح يمكنك إرفاق الملف المرغوب دمجه ربما نستطيع مساعدتك

وعليكم السلام ورحمة الله تعالى وبركاته حل اخر بإستخدام الأكواد Option Explicit Private Sub Worksheet_Change(ByVal Target As Range) Dim lastRow As Long, i As Long, n As Long, tmp As Variant, a As Object If Intersect(Target, Me.Columns("A:B")) Is Nothing Then Exit Sub Application.EnableEvents = False Application.ScreenUpdating = False On Error Resume Next lastRow = Me.Columns("A:B").Find(What:="*", _ SearchDirection:=xlPrevious, SearchOrder:=xlByRows).Row On Error GoTo 0 If lastRow < 2 Then GoTo CleanUp Me.Range("A2:A" & lastRow).ClearContents tmp = Me.Range("B2:B" & lastRow).Value: Set a = CreateObject("Scripting.Dictionary") For i = 1 To UBound(tmp) If Len(Trim(tmp(i, 1))) > 0 And Not a.exists(tmp(i, 1)) Then n = n + 1: a(tmp(i, 1)) = n: Me.Cells(i + 1, "A").Value = n End If Next i CleanUp: Application.ScreenUpdating = True Application.EnableEvents = True End Sub ترقيم بتجاوز المكرر.xlsb

السلام عليكم دالة countif مضافاً إليها دالة max ضعها في a2 ثم اسحبها للاسفل =IF(COUNTIF($B$2:B2; B2)=1; MAX($A$1:A1)+1; "") ملف ترقيم بتجاوز المكرر.xlsx

تفضل استاذ @amqadri المرفق بعد التعديل بطلبك .ووافني بالرد . data (2).rar

ممكن كتابة الكود التالى فى ملف Text ثم بعد ذلك حفظ الملف باسم : UnblockDatabase.ps1 حتى يكون الملف الناتج عبارة عن ملف : PowerShell ويتم تشعيل الملف كمسئول وظيفة الكود الدوران على قواعد البيانات الموجوده فى المجلد الحالى او المجلدات الفرعيه للمجلد الحالى وازالة الحظر لهذه القواعد واقصد بالحظر هنا الموجودة بالصورة التاليه # التحقق من صلاحيات المسؤول if (-not ([Security.Principal.WindowsPrincipal] [Security.Principal.WindowsIdentity]::GetCurrent()).IsInRole([Security.Principal.WindowsBuiltInRole] "Administrator")) { Write-Host "❌ يجب تشغيل السكربت بصلاحيات المسؤول لتعيين سياسة التنفيذ." exit } # تعيين سياسة التنفيذ Set-ExecutionPolicy -Scope LocalMachine -ExecutionPolicy RemoteSigned -Force Write-Host "✅ تم تعيين سياسة التنفيذ إلى RemoteSigned على مستوى الجهاز." # الحصول على المسار الحالي للمجلد الذي يحتوي على الكود $currentFolder = $PSScriptRoot # البحث عن جميع ملفات قواعد البيانات (مثل *.accdb و *.mdb) في المجلد الحالي والمجلدات الفرعية $databaseFiles = Get-ChildItem -Path $currentFolder -Include *.accdb, *.mdb -Recurse # التحقق من وجود ملفات قاعدة البيانات if ($databaseFiles) { foreach ($file in $databaseFiles) { try { # إزالة الحظر من الملف $zoneIdentifier = "$($file.FullName):Zone.Identifier" if (Test-Path $zoneIdentifier) { Remove-Item -Path $zoneIdentifier -Force Write-Host "تم إزالة الحظر من الملف: $($file.FullName)" } else { Write-Host "الملف غير محظور: $($file.FullName)" } } catch { Write-Host "حدث خطأ أثناء محاولة إزالة الحظر من الملف: $($file.FullName) - $_" } } } else { Write-Host "لم يتم العثور على ملفات قاعدة بيانات في المجلد الحالي." } UnblockDatabase.zip

هذه تساعدك على الترتيب تصاعديا وتنازليا بشكل صحيح = "D:\الهويات\Pictures\" & TEXT(ROW(),"00000") & ".jpg"

وعليكم السلام ورحمة الله وبركاته ="D:\الهويات\Pictures\" & ROW(A1) & ".jpg" ثم لسحب للاسفل ويمكنك نسخها ولصقها كقيم يعد ذلك New Microsoft Excel Worksheet.xlsx

السلام عليكم ورحمة الله وبركاته ، أخواني وأساتذتي ومعلمينا ( دون استثناء ) 📌 أقدم لكم اليوم فكرة قد تكون ليست بالجديدة ، ولكن بطريقة ونكهة مختلفتين ▫▪◽◾◻◼. "أداة مستورد السجلات الذكي من Excel" ، أداة مبتكرة تتيح لك استيراد البيانات من ملفات Excel إلى قواعد بيانات Access بكل مرونة وسرعة . يتميز هذا البرنامج أو الأداة بواجهة بسيطة وميزات قوية تجعل التعامل مع البيانات تجربة مريحة ، حتى للمستخدمين الذين ليست لديهم خبرة تقنية كبيرة في التعامل مع هذا النوع من المتطلبات . فالكثير من الأشخاص في منتدانا هنا سأل عن إمكانية استيراد بيانات من اكسل من حقل محدد أو بطرق محددة ( تناسب إحتياجاته ) ، ولهذا كانت الفكرة هذه تنفيذاً لمتطلباتهم .. 🎯 سنستعرض أهم ميزات هذا البرنامج وكيف يمكن أن يسهم في تحسين إنتاجيتك وتوفير وقتك . تابع القراءة لاكتشاف كيف يمكنك الاستفادة من هذا الحل الذكي لإدارة البيانات 😇 . ميزات برنامج مستورد السجلات الذكي من Excel 📂 التكامل مع Excel يمكن اختيار ملفات Excel بسهولة باستخدام نافذة اختيار الملفات . يدعم البرنامج ملفات بصيغة xls / xlsx . 📋 التعامل مع الأوراق والبيانات عرض جميع أوراق العمل (Sheets) الموجودة في ملف Excel المحدد . عرض أسماء الأعمدة في الورقة المحددة لتسهيل تحديد العمود المستهدف . 🚀 الاستيراد المرن للبيانات استيراد بيانات من عمود محدد في ملف Excel بناءً على اختيار المستخدم . تحديد الصفوف التي تبدأ منها عملية الاستيراد (لتجاوز رؤوس الأعمدة إن وجدت 👌 ) . 🗂️ الإدارة المتقدمة للبيانات داخل Access استيراد البيانات إلى جدول محدد داخل قاعدة البيانات الحالية . دعم لتحديد الحقول الهدف داخل الجدول . إمكانية تفعيل خاصية الترقيم التلقائي لإضافة قيم تسلسلية إلى الحقول المخصصة ( باستخدام الدالة DMAX ). ⚡ أداء عالي مع دفعات من البيانات تقسيم البيانات إلى دفعات عند استيراد كميات كبيرة لتجنب مشاكل الأداء . إدارة مرنة لعدد السجلات التي يتم استيرادها في كل دفعة . 🎨 واجهة مستخدم ديناميكية إظهار أو إخفاء المساعدة البصرية بضغطة زر . تحديث الكومبوبوكس بطريقة ديناميكيًا بناءً على اختيارات المستخدم . 🔒 إجراءات أمان واسترجاع دعم لاسترجاع البيانات عند حدوث خطأ أثناء عملية الاستيراد ( Rollback ) . التنبيه برسائل خطأ واضحة إذا لم يتم اختيار الملف أو إعداد الخيارات بشكل صحيح . 🧹 إدارة الموارد تنظيف جميع الموارد المفتوحة (ملفات Excel أو الاتصال بالبيانات) عند إغلاق النموذج . منع أي تأثير سلبي على النظام عند حدوث خطأ . ✨ سهولة الاستخدام تصميم بسيط يعرض التعليمات ويطلب إدخال البيانات الضرورية فقط . رسائل توجيهية للمستخدم لتحسين تجربة الاستخدام . ⚙️ المرونة في تخصيص الخيارات خيارات لتحديث السجلات الموجودة أو إضافة سجلات جديدة . دعم مجموعات البيانات المختلفة من خلال تحديد طريقة المعالجة . صورة واجهة الأداة .. الملف المرفق مفتوح المصدر .. 💢 Excel Importor.accdb 💢 **************************** ما الجديد في هذا للتحديث ؟ 📊 واجهة المستخدم (UI) : واجهة مستخدم تحتوي على أزرار وخيارات لتسهيل عملية استيراد البيانات من إكسل إلى أكسيس . 📂 يمكن للمستخدم اختيار ملف إكسل من خلال مربع حوار اختيار الملفات . يتم تحميل بيانات الملف المحدد وعرض أسماء الأوراق (Sheets) والأعمدة (Columns) في القوائم المنسدلة . 📥 يدعم الكود طريقتين لاستيراد البيانات : 🔢 استيراد عمود واحد ( الإصدار الأول ): حيث يتم استيراد بيانات عمود معين من إكسل إلى حقل محدد في جدول أكسيس. 🔢🔢 استيراد عدة أعمدة ( بناءً على طلب الأخوة ): حيث يتم استيراد بيانات عدة أعمدة من إكسل إلى عدة حقول في جدول أكسيس. 💥 يتم التحقق من صحة البيانات المحددة قبل بدء عملية الاستيراد . 🔢 إدارة الترقيم التلقائي : يدعم البرنامج إمكانية الترقيم التلقائي للحقول المحددة أثناء عملية الاستيراد . يمكن للمستخدم تفعيل أو تعطيل هذه الميزة وتحديد الحقل الذي سيتم الترقيم التلقائي عليه . ⚠️ إدارة الأخطاء : يتم التعامل مع الأخطاء المحتملة أثناء عملية الاستيراد ( مثل عدم وجود ملف إكسل محدد أو عدم تطابق الأعمدة ... إلخ ) . الملف المرفق مفتوح المصدر .. 💢 Excel Importor 2025.accdb1.07 \u0645\u064a\u062c\u0627 \u0628\u0627\u064a\u062a · 20 downloads 💢 🔴 وجب علي التنويه إلى نقطة مهمة وهي :- قد يأتي أحد الأخوة لاختيار ملف يحتوي على ترويسة أو صورة في أول ملف الإكسل الذي اختاره ، ويقول لي أنه لم يظهر لي أي أسماء للأعمدة التي تحدثت عنها ( وأن الأداة لم تخدمه بشكل أو بآخر ) وهنا وأعتذر منه مسبقاً بأن هذا الخلل ليس في الأداة وإنما في ملف الآكسل . فأنا لا استطيع أن أجبرك على تصميم معين لملف الآكسل الذيتريد الإستيراد منه ، ولكني بنفس الوقت أقترح عليك أن تزيل هذه الإضافات والمعوقات كي تستفيد من الأداة بشكل ممتاز .

أظن أنه يمكننا إضافة شرط التحقق من كلمة المرور عند محاولة غلق الحسابات في الكود بحيث لا يمكن لأي شخص تنفيذه إلا إذا كان يعرف كلمة المرور الصحيحة هذا يضيف طبقة أمان إضافية للحماية ويضمن أن الشخص الذي يقوم بالعملية هو الشخص المخول فقط جرب هدا التعديل Option Explicit Private Const Clé As String = "1234" Public Property Get WS() As Worksheet Set WS = Sheets("Sheet1") End Property Sub ProtectSheet(xligne As Long) With WS .Unprotect Password:=Clé: .Cells.Locked = False .Range("A2:M" & xligne).FormulaHidden = True .Range("A2:M" & xligne).Locked = True: .Protect Password:=Clé End With End Sub Sub WSUnprotect() With WS .Unprotect Password:=Clé .Cells.Locked = False .Cells.FormulaHidden = False End With End Sub Sub Data_Protection() Dim xligne As Long If InputBox("أدخل كلمة المرور للمتابعة") <> Clé Then MsgBox "كلمة المرور غير صحيحة تم إلغاء العملية", vbCritical Exit Sub End If xligne = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If xligne < 1 Or xligne > WS.Rows.Count Then MsgBox "خطأ في الإدخال يرجى إدخال رقم صف صحيح", vbExclamation Exit Sub End If SetApp False ProtectSheet xligne SetApp True MsgBox "تم قفل الحسابات بنجاح لغاية الصف: " & xligne, vbInformation End Sub Sub Data_UnProtection() Dim PassProtect As String PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = Clé Then SetApp False: WSUnprotect: SetApp True MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation ElseIf PassProtect <> "" Then MsgBox "كلمة المرور غير صحيحة", vbCritical End If End Sub Private Sub SetApp(ByVal enable As Boolean) On Error GoTo xError Application.ScreenUpdating = enable Application.EnableEvents = enable Application.Calculation = IIf(enable, xlCalculationAutomatic, xlCalculationManual) Exit Sub xError: End Sub غلق المدى المحدد .xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا في Module ضع الكود التالي Sub ColoriageDoublons() Dim WSarr As Variant, couleurs As Long, d As Object, _ s As Variant, OnRng As Range, lastRow As Long, a, i As Long WSarr = Array(1, 2, 3): couleurs = RGB(0, 204, 255) Set d = CreateObject("Scripting.Dictionary") For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row a = .Range("C4:C" & lastRow).Value For i = 1 To UBound(a, 1) If a(i, 1) <> "" Then d(a(i, 1)) = d(a(i, 1)) + 1 Next i End With Next s For Each s In WSarr With Sheets(s) lastRow = .Cells.Find(What:="*", LookIn:=xlValues, _ SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set OnRng = .Range("C4:C" & lastRow) a = OnRng.Value For i = 1 To UBound(a, 1) OnRng.Cells(i).Interior.Color = IIf(a(i, 1) <> "" And d(a(i, 1)) > 1, couleurs, xlNone) Next i End With Next s End Sub وفي حدث ThisWorkbook Option Explicit Private Sub Workbook_SheetChange(ByVal Sh As Object, ByVal Target As Range) Dim WSarr As Variant WSarr = Array("1", "2", "3") If Not Intersect(Target, Sh.Columns("C")) Is Nothing And Target.Row >= 4 Then Application.ScreenUpdating = False If Not IsError(Application.Match(Sh.Name, WSarr, 0)) Then Call ColoriageDoublons End If Application.ScreenUpdating = True End If End Sub تلوين الخلايا v2 المكررة.xlsm

وعليكم السلام ورحمة الله تعالى وبركاته Sub SaveAsPDF() Const Max As Long = 1000 Dim WS As Worksheet, Irow As Long, OnRng As Range Dim xPath As String, Dossier As String, Fichier As String Set WS = Sheets("Sheet1") Irow = WS.Cells(WS.Rows.Count, "A").End(xlUp).Row If Irow > Max Then Irow = Max: Set OnRng = WS.Range("A2:Z" & Irow) If Application.WorksheetFunction.CountA(OnRng) = 0 Then Exit Sub WS.ResetAllPageBreaks With WS.PageSetup .PrintArea = OnRng.Address: .Orientation = xlPortrait: .PaperSize = xlPaperA4 .Zoom = False: .FitToPagesWide = 1: .FitToPagesTall = False End With Dossier = ThisWorkbook.Path & "\ملفات PDF" If Dir(Dossier, vbDirectory) = "" Then MkDir Dossier Fichier = Replace(WS.Range("AA1").Value, "/", "_") xPath = Dossier & "\" & Fichier & " " & Format(Now, "yyyy-mm-dd hh.mm") & ".pdf" WS.ExportAsFixedFormat Type:=xlTypePDF, FileName:=xPath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False WS.PageSetup.PrintArea = "" MsgBox "تم حفظ الملف بنجاح ", vbInformation End Sub Test-PDF.xlsb

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا حفظ الملفات في تفس مسار الملف Option Explicit Sub SAVE_PDF() Dim ScWS As Variant, Path As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" If Path = "\" Then Exit Sub For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub لإنشاء مجلد وحفظ الملفات بداخله Sub SAVE_PDF_Folder() Dim ScWS As Variant, Path As String, Dossier As String, i As Integer ScWS = Array("Sheet1", "Sheet2", "Sheet3") Path = ThisWorkbook.Path & "\" Dossier = "ملفات PDF" If Path = "\" Then Exit Sub If Dir(Path & Dossier, vbDirectory) = "" Then MkDir Path & Dossier Path = Path & Dossier & "\" For i = LBound(ScWS) To UBound(ScWS) If Not ShExists(ScWS(i)) Then MsgBox "الورقة " & ScWS(i) & " غير موجودة": Exit Sub Application.ScreenUpdating = False On Error Resume Next Sheets(ScWS(i)).ExportAsFixedFormat Type:=xlTypePDF, FileName:=Path & ScWS(i) & ".pdf", _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False On Error GoTo 0 Next i Application.ScreenUpdating = True MsgBox "تم حفظ الملفات بنجاح" End Sub Function ShExists(ByVal SheetName As String) As Boolean On Error Resume Next: ShExists = Not Sheets(SheetName) Is Nothing: On Error GoTo 0 End Function حفظ الملفات مستقلة بصيغة PDF.xlsb

السلام عليكم الحمد لله تم اصلاح العطل بالمنتدى بواسطة فلترة البيانات بالعمود الاول A يمكن تعديل حسب العمود الذي به بيانات في الجزء Field:=1 الكود Sub SaveRangeAsPDF() Dim ws As Worksheet Dim savePath As String Set ws = ThisWorkbook.Sheets("ورقة1") With ws .Range("A1:Z999").AutoFilter Field:=1, Criteria1:="<>" savePath = "D:\" & .Range("AA1").Value & " " & Format(Now, "yyyy-mm-dd,hh.mm") & ".pdf" .Range("A1:Z999").ExportAsFixedFormat Type:=xlTypePDF, Filename:=savePath, _ Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False .AutoFilterMode = False End With MsgBox "تم حفظ الملف بنجاح!", vbInformation, "حفظ PDF" End Sub الملف DFP2.xlsb

السلام عليكم ورحمة الله وبركاته اقدم اليكم مكتبة مرنة وشاملة و متقدمة لإدارة و التعامل مع الملفات والمجلدات قمت بكتابتها بشكل مرن وإحترافي بمعنى الكلمة يحدد ما إذا كان المستخدم سيختار ملفًا أو مجلدًا يحدد شكل الإخراج (المسار الكامل، الاسم فقط، أو الاسم مع الامتداد) تصنيف الملفات حسب نوعها و تصفية الملفات المعروضة اختيار متعدد أو فردي اليكم الأكواد كاملة هديــــة لأخوانى وأحبابى Option Compare Database Option Explicit ' Global variables for file selection and allowed extensions Public IsFolderMode As Boolean ' Toggle folder selection mode Public AllowedExtensions As Collection ' Store allowed file extensions ' Enumeration for File Dialog Types Public Enum FileDialogType FilePicker = 1 ' Dialog for selecting files FolderPicker = 4 ' Dialog for selecting folders End Enum ' Enumeration for processing file path Public Enum FileProcessingMode FullPath = 1 ' Return the full file path NameWithoutExtension = 2 ' Return the file name without extension NameWithExtension = 3 ' Return the file name with extension End Enum ' Enumeration for file categories Public Enum FileCategory AccessFiles = 1 ' Access Database files (accdb, mdb, accda, etc.) ExcelFiles = 2 ' Excel files (xlsx, xls, xlsm, etc.) WordFiles = 3 ' Word files (docx, doc, docm, etc.) ImageFiles = 4 ' Images category (jpg, png, gif, bmp, tiff, etc.) AudioFiles = 5 ' Audio category (mp3, wav, ogg, flac, etc.) VideoFiles = 6 ' Video category (mp4, avi, mov, mkv, etc.) AcrobatFiles = 7 ' Acrobat PDF files (pdf) TextFiles = 8 ' Text files (txt, csv, log, md, etc.) PowerPointFiles = 9 ' PowerPoint files (pptx, ppt, pptm, etc.) CompressedFiles = 10 ' Compressed files (zip, rar, 7z, tar, gz, etc.) CodeFiles = 11 ' Code files (html, css, js, php, py, java, etc.) ExecutableFiles = 12 ' Executable files (exe, bat, cmd, apk, etc.) AllFiles = 13 ' All file types (*.*) End Enum ' Initialize the allowed extensions for a specific file category Sub InitializeExtensions(ByVal Category As FileCategory) Set AllowedExtensions = New Collection Select Case Category ' Access Database files Case AccessFiles AddExtensions Array("accda", "accdb", "accde", "accdr", "accdt", "accdw", "mda", "mdb", "mde", "mdf", "mdw") ' Excel files Case ExcelFiles AddExtensions Array("xlsx", "xls", "xlsm", "xlsb", "xltx", "xltm") ' Word files Case WordFiles AddExtensions Array("docx", "doc", "docm", "dotx", "dotm", "rtf", "odt") ' Image files Case ImageFiles AddExtensions Array("jpg", "jpeg", "png", "gif", "bmp", "tiff", "tif", "ico", "webp", "heif", "heic") ' Audio files Case AudioFiles AddExtensions Array("mp3", "wav", "ogg", "flac", "aac", "m4a", "wma", "alac", "opus", "aiff") ' Video files Case VideoFiles AddExtensions Array("mp4", "avi", "mov", "mkv", "flv", "wmv", "webm", "mpeg", "mpg", "3gp", "ts") ' Acrobat PDF files Case AcrobatFiles AllowedExtensions.Add "pdf" ' Text files Case TextFiles AddExtensions Array("txt", "csv", "log", "md", "rtf") ' PowerPoint files Case PowerPointFiles AddExtensions Array("pptx", "ppt", "ppsx", "pps", "pptm", "potx", "potm") ' Compressed files (Archives) Case CompressedFiles AddExtensions Array("zip", "rar", "7z", "tar", "gz", "tar.gz", "tgz", "xz", "bz2") ' Code files Case CodeFiles AddExtensions Array("html", "css", "js", "php", "py", "java", "cpp", "c", "rb", "swift", "go", "ts") ' Executable files Case ExecutableFiles AddExtensions Array("exe", "bat", "cmd", "msi", "apk", "app", "dmg", "jar") ' All file types Case AllFiles AllowedExtensions.Add "*.*" Case Else MsgBox "Invalid category provided!", vbCritical End Select End Sub ' Add an array of extensions to the AllowedExtensions collection Private Sub AddExtensions(ByVal ExtensionsArray As Variant) Dim Extension As Variant For Each Extension In ExtensionsArray AllowedExtensions.Add Extension Next Extension End Sub ' Display a file or folder dialog and return the selected files Function GetFiles(Optional ByVal Extensions As Collection = Nothing, Optional ByVal SingleFile As Boolean = False) As Collection Dim FileDialog As Object Dim FolderDialog As Object Dim SelectedFiles As New Collection Dim FolderPath As String Dim FilterString As String On Error GoTo ErrorHandler ' Build the file dialog filter FilterString = BuildFilterString(Extensions) If Not IsFolderMode Then ' File selection dialog Set FileDialog = Application.FileDialog(FileDialogType.FilePicker) With FileDialog .Title = "Select File(s)" .AllowMultiSelect = Not SingleFile .Filters.Clear .Filters.Add "Allowed Files", FilterString If .Show = -1 Then AddSelectedFilesToCollection FileDialog, SingleFile, SelectedFiles End If End With Else ' Folder selection dialog Set FolderDialog = Application.FileDialog(FileDialogType.FolderPicker) With FolderDialog .Title = "Select Folder" If .Show = -1 Then FolderPath = .SelectedItems(1) SelectedFiles.Add FolderPath End If End With End If ' Return the selected files or folder If SelectedFiles.Count > 0 Then Set GetFiles = SelectedFiles Else MsgBox "No files or folder selected.", vbExclamation Set GetFiles = Nothing Exit Function End If CleanUp: Set FileDialog = Nothing Set FolderDialog = Nothing Exit Function ErrorHandler: MsgBox "An error occurred: " & Err.Description, vbCritical Resume CleanUp End Function ' Build the file dialog filter string Private Function BuildFilterString(ByVal Extensions As Collection) As String Dim Filter As String Dim Extension As Variant If Not Extensions Is Nothing Then For Each Extension In Extensions Filter = Filter & "*." & Extension & ";" Next Extension If Len(Filter) > 0 Then Filter = Left(Filter, Len(Filter) - 1) Else Filter = "*.*" End If BuildFilterString = Filter End Function ' Add selected files to the collection Private Sub AddSelectedFilesToCollection(ByVal Dialog As Object, ByVal SingleFile As Boolean, ByRef FilesCollection As Collection) Dim Index As Long If SingleFile Then FilesCollection.Add Dialog.SelectedItems(1) Else For Index = 1 To Dialog.SelectedItems.Count FilesCollection.Add Dialog.SelectedItems(Index) Next Index End If End Sub ' Function to check if the file extension is allowed Function IsAllowedExtension(ByVal strExt As String, ByVal colExtensions As Collection) As Boolean Dim varExt As Variant If colExtensions Is Nothing Or colExtensions.Count = 0 Then IsAllowedExtension = True ' Allow all extensions if colExtensions is Nothing or empty Exit Function End If For Each varExt In colExtensions If LCase(strExt) = LCase(varExt) Then IsAllowedExtension = True Exit Function End If Next varExt IsAllowedExtension = False End Function ' Subroutine to select a folder and retrieve all files based on allowed extensions Sub SelectFilesInFolder(ByVal FileCategoryType As FileCategory) Dim SelectedFiles As Collection ' Collection to hold the selected files Dim FolderPath As String ' Folder path selected by the user Dim CurrentFileName As String ' Current file name during folder iteration Dim FileExtension As String ' File extension for the current file Dim FilteredFiles As New Collection ' Collection to hold filtered files Dim FileItem As Variant ' Variable to iterate through filtered files On Error GoTo ErrorHandler ' Handle errors if they occur ' Enable folder selection mode IsFolderMode = True ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a folder Set SelectedFiles = GetFiles(Nothing, False) ' Pass Nothing for extensions as folder mode doesn't filter by type ' Check if a folder was selected If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Get the first (and only) selected folder path FolderPath = SelectedFiles(1) ' Start iterating through all files in the selected folder CurrentFileName = Dir(FolderPath & "\*.*") ' Retrieve the first file in the folder Do While CurrentFileName <> "" ' Extract file extension and convert it to lowercase FileExtension = LCase(Split(CurrentFileName, ".")(UBound(Split(CurrentFileName, ".")))) ' Check if the file extension is allowed and add it to the filtered collection If IsAllowedExtension(FileExtension, AllowedExtensions) Then FilteredFiles.Add FolderPath & "\" & CurrentFileName End If ' Retrieve the next file in the folder CurrentFileName = Dir Loop ' If there are filtered files, display their paths If FilteredFiles.Count > 0 Then For Each FileItem In FilteredFiles Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files found matching the allowed extensions.", vbExclamation End If Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub Sub SelectFolderPath() On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim colFiles As Collection IsFolderMode = True ' Set folder mode to true for folder selection Set colFiles = GetFiles(Nothing, False) ' Pass Nothing for colExtensions as we are dealing with folders On Error Resume Next If Not colFiles Is Nothing And colFiles.Count > 0 Then PrintFilePaths colFiles Else MsgBox "No folder selected.", vbExclamation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate single file selection with specific extensions Sub SelectSingleFile(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select a single file with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, True) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to demonstrate multiple file selection with specific extensions Sub SelectMultipleFiles(ByVal FileCategoryType As FileCategory) On Error GoTo ErrorHandler ' Handle errors if they occur ' Collection to hold the selected files Dim SelectedFiles As Collection ' Set file selection mode IsFolderMode = False ' Initialize allowed extensions for the specified file category InitializeExtensions FileCategoryType ' Prompt user to select multiple files with allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Print selected file path(s) PrintFilePaths SelectedFiles Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Subroutine to print file paths from a collection Sub PrintFilePaths(ByVal Files As Collection) ' Variable to iterate through filtered files Dim FileItem As Variant ' Check if the collection is valid and contains files If Not Files Is Nothing And Files.Count > 0 Then For Each FileItem In Files Debug.Print "Selected File: " & FileItem Next FileItem Else MsgBox "No files were selected or matched the allowed extensions.", vbExclamation End If End Sub ' Subroutine to process file paths, extract name, name without extension, and extension Sub ProcessFilePaths(ByVal colFiles As Collection) ' Variable to iterate through the collection Dim varFilePath As Variant ' Variable to hold the current file path as a string Dim strFilePath As String ' Variables to hold extracted components of the file path Dim fileName As String Dim fileNameWithoutExt As String Dim fileExt As String ' Check if the collection is not empty or Nothing If Not colFiles Is Nothing Then ' Loop through each file path in the collection For Each varFilePath In colFiles ' Assign the current file path to a string variable strFilePath = varFilePath ' Extract the file name from the full path fileName = GetFileNameFromPath(strFilePath) ' Extract the file name without the extension fileNameWithoutExt = GetFileNameWithoutExtension(strFilePath) ' Extract the file extension (including the dot) fileExt = GetFileExtension(strFilePath) ' ' Print the extracted information to the Immediate Window (Ctrl+G in VBA Editor) ' Debug.Print "Full Path: " & varFilePath ' Debug.Print "File Name: " & fileName ' Debug.Print "File Name Without Extension: " & fileNameWithoutExt ' Debug.Print "File Extension: " & fileExt ' Debug.Print "------------------------------" Next varFilePath Else ' Show a message box if the collection is empty or Nothing MsgBox "No files found.", vbInformation End If End Sub ' Function to extract the file name (including extension) from a full file path Function GetFileNameFromPath(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameFromPath = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim pos As Long pos = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If pos = 0 Then pos = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract and return the file name If pos > 0 Then GetFileNameFromPath = Mid(FilePath, pos + 1) ' Return everything after the last separator Else GetFileNameFromPath = FilePath ' If no separator is found, return the full path End If End Function ' Function to extract the file name without its extension from a full file path Function GetFileNameWithoutExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileNameWithoutExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last backslash in the file path Dim posBackslash As Integer posBackslash = InStrRev(FilePath, "\") ' Find the position of the last backslash ' If no backslash is found, check for forward slash (e.g., for web paths) If posBackslash = 0 Then posBackslash = InStrRev(FilePath, "/") ' Find the position of the last forward slash End If ' Extract the file name (with extension) Dim fileName As String If posBackslash > 0 Then fileName = Mid(FilePath, posBackslash + 1) ' Extract the file name Else fileName = FilePath ' If no separator, the full path is considered the file name End If ' Search for the last dot in the file name to identify the extension Dim posDot As Integer posDot = InStrRev(fileName, ".") ' Find the position of the last dot ' Remove the extension if a dot is found If posDot > 0 Then GetFileNameWithoutExtension = Left(fileName, posDot - 1) ' Return the name without the extension Else GetFileNameWithoutExtension = fileName ' If no dot, return the full file name End If End Function ' Function to extract the file extension (including the dot) from a full file path Function GetFileExtension(FilePath As String) As String ' Check if the file path is empty If Len(FilePath) = 0 Then GetFileExtension = "" ' Return an empty string if no path is provided Exit Function End If ' Search for the last dot in the file path Dim posDot As Integer posDot = InStrRev(FilePath, ".") ' Find the position of the last dot ' Extract and return the file extension If posDot > 0 Then GetFileExtension = Mid(FilePath, posDot) ' Return everything after (and including) the last dot Else GetFileExtension = "" ' If no dot is found, return an empty string End If End Function ' Subroutine to save file paths or details into a database table ' Parameters: ' - SelectedFiles: Collection of selected file paths. ' - TableName: Name of the database table where data will be saved. ' - FieldName: Name of the field in the table to store the file information. ' - ProcessingMode: Determines how the file paths will be processed before saving. Default is FullPath. Sub SaveFileDetailsToTable(SelectedFiles As Collection, TableName As String, FieldName As String, Optional ByVal ProcessingMode As FileProcessingMode = FullPath) On Error GoTo ErrorHandler ' Handle errors if they occur Dim varFilePath As Variant Dim ProcessedValue As String ' Check if the SelectedFiles collection is valid and contains files If Not SelectedFiles Is Nothing And SelectedFiles.Count > 0 Then ' Loop through each file in the collection For Each varFilePath In SelectedFiles ' Determine how the file path should be processed based on ProcessingMode Select Case ProcessingMode Case FullPath ' Use the full file path as the value to save ProcessedValue = CStr(varFilePath) Case NameWithoutExtension ' Extract and use the file name without its extension ProcessedValue = GetFileNameWithoutExtension(CStr(varFilePath)) Case NameWithExtension ' Extract and use the file name including its extension ProcessedValue = GetFileNameFromPath(CStr(varFilePath)) Case Else ' Default to using the full file path ProcessedValue = CStr(varFilePath) End Select ' Construct the SQL statement to insert the processed value into the specified table and field Dim SQL As String SQL = "INSERT INTO [" & TableName & "] ([" & FieldName & "]) VALUES ('" & Replace(ProcessedValue, "'", "''") & "')" ' Execute the SQL statement to save the data into the database CurrentDb.Execute SQL, dbFailOnError Next varFilePath Else ' Display a message if no files were found in the collection MsgBox "No files found.", vbInformation End If Exit Sub ' Error handler to catch and display error 91 (and other errors if any) ErrorHandler: If Err.Number = 91 Then Exit Sub Else MsgBox "An unexpected error occurred: " & Err.Description, vbCritical End If Resume Next End Sub ' Test method to demonstrate saving file details to a table ' This subroutine selects files and saves their names without extensions into a database table Sub TestSaveResults() Dim SelectedFiles As Collection ' Set mode to file selection mode IsFolderMode = False ' Initialize allowed extensions for the specific category (e.g., images in this case) InitializeExtensions ImageFiles ' Prompt the user to select files based on the allowed extensions Set SelectedFiles = GetFiles(AllowedExtensions, False) ' Save the selected file names (without extensions) into the table "tblMedia" in the "fieldName" column SaveFileDetailsToTable SelectedFiles, "tblMedia", "fieldName", NameWithoutExtension End Sub ' Test the functionality of retrieving a folder path Sub TestGetFolderPath() ' Call the Select Folder function to get the folder path SelectFolderPath End Sub ' Test the functionality of selecting files in a folder based on the specified file category Sub TestSelectFilesInFolder() ' Call the SelectFilesInFolder function to select audio files from a folder SelectFilesInFolder AudioFiles End Sub ' Test the functionality of selecting a single file based on the specified file category Sub TestSelectSingleFile() ' Call the SelectSingleFile function to select a single audio file SelectSingleFile AudioFiles End Sub ' Test the functionality of selecting multiple files based on the specified file category Sub TestSelectMultipleFiles() ' Call the SelectMultipleFiles function to select multiple audio files SelectMultipleFiles AudioFiles End Sub

=============================================( صور + مرفق + فيديو ) Update: 🌹 بعد اذن الاستاذ @Moosak ❤️🌹☕ تغير الدالة مع الكود بمرفقك بالكامل يعمل مع اي تقرير او نموذج من غير كتابة اسمة بداله واحده فقط 😇 تلقائي Auto اسهل صلاحيات لكافة النماذج والتقارير والطباعة بدالة وحده اشر بالجدول بس يعني سو جدول وتقرير جديد اختر من الجدول صلاحيات مباشره شباب ؟! 😂 (حدث عند التحميل) كود الاستدعاء: '=============================( Only 2 Code Function For Chack User '=====================================( IF Form (1) Call FormsAllowed(Me.Form.name) '=====================================( IF Report (1) 'Call FormsAllowed(Me.Report.name) الدالة : Option Compare Database Option Explicit Public Function FormsAllowed(ByVal strname As String) As String '(FrmName As String) As Boolean ' ===========! Dim name_x As String name_x = FormsAllowed '==============================================(Chack frist) If IsNull(DLookup("[name_frm]", "[Control_User]", "[name_frm] ='" & strname & "'")) Then MsgBox " Opes back setting for Error Forget this form Open Or Now Awoch ", vbCritical, "Close Done " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( Open Form If DLookup("[open_frm]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then DoCmd.OpenForm strname Else MsgBox "لا تملك صلاحية الدخول او ليس لك حق الدخول او تم حظرك من الدخول او تم منعك من الدخول ", vbExclamation, "رسالة ادارية راجع المسؤل المختص " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( AllowAddition If DLookup("[add_new]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then Forms(strname).AllowAdditions = True Else Forms(strname).AllowAdditions = False End If '============================================================================( AllowDeletion If DLookup("[delet]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then Forms(strname).AllowDeletions = True Else Forms(strname).AllowDeletions = False End If '============================================================================( AllowEdits If DLookup("[editor]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then Forms(strname).AllowEdits = True Else Forms(strname).AllowEdits = False End If End Function Public Function Print_Allowed(ByVal strname As String) As String '==============================================(Chack frist) If IsNull(DLookup("[name_frm]", "[Control_User]", "[name_frm] ='" & strname & "'")) Then MsgBox " Opes back setting for Error Forget this form Open Or Now Awoch ", vbCritical, "Close Done " & Date DoCmd.Close acForm, strname Exit Function End If '============================================================================( Print into Button Or If Keybord If DLookup("[print]", "[Control_User]", "[name_frm] ='" & strname & "'") = True Then DoCmd.OpenReport strname DoCmd.RunCommand acCmdPrint Else MsgBox "لا تملك صلاحية طباعة التقرير او ليس لك حق بالطباعة او تم حظرك من الطباعة او تم منعك من الطباعة ", vbExclamation, "رسالة ادارية راجع المسؤل المختص " & Date Exit Function End If End Function @dd13901390🌹☕ 2- تعديل واستكمال بعض تابع الفيديو للتوضيح اسفل الموضوع + تحميل المرفق ☕ =============================================( مرفق + فيديو ) V2_One_FunctionLoginIN_Whit_Exprot_FileAuto_Ms_Access.rar