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

السلام عليكم ورحمه الله وبركاته دا جزاء من مشروع شغال عليه يلمس هذا الموضوع ساقوم بإرفاق ملف الوظائف التي يقوم بها 1- تعطيل / تفعيل مفتاح الشفت 2-ربط ديناميكي / ربط يدوي لــ الواجهات الاماميه (النماذج) مع الواجهات الخلفيه (الجداول) 3-اخفاء جميع كائنات الاكسس الواجهات الاماميه (النماذج) مع عدم القدره ع استيرادها من ملف اكسس اخر 4-اخفاء جميع كائنات الاكسس من الواجهات الخلفيه (الجداول) مع عدم القدره ع استيرادها من ملف اكسس اخر يرجي الافاده بعد التجربه خاص اوفسينا.rar

تفضل وجدت الخلل في ترتيب شروط الدالة عدلتها وايضا عدلت على دالة النتيجة النهائية مثلها بالضبط ايضا لاحظ اني عملت متغير عام يأخذ قيمته عند حدث بعد التحديث لحقل الصف في نموذج التقارير .. وقيمته هي معرف الصف البحث وتعديل درجات3.rar

السلام عليكم ورحمة الله وبركاته الأخوة الكرام بارك الله فيكم تجدون بالملف المرفق قاعدة بيانات بها - [ awsReg ] وهو Class Module للتحكم بالريجيستري [ Windows Registry ] - [ awsReg_Test_Module ] وهو مديول به نماذج لتوضيح كيفية للإستخدام حاولت قدر المستطاع تغطية جميع الإستخدامات - [ باقي المديولز ] هي ضرورية للعمل نبذة مختصرة - مصدر الكود من هنا : https://learn.microsoft.com/en-us/previous-versions/office/developer/office2000/aa155731(v=office.10)?redirectedfrom=MSDN&ref=nolongerset.com - من قام بتعديل التعريفات لتناسب 64x من هنا : https://nolongerset.com/regop-class-for-64-bit-vba/ - قمت بفضل الله ونعمتة ( الحمد كله لله أوله وأخره) 1- دمج وتجهيز الكود بالكامل 😁 2- تعديل نظام عرض الرسائل والأخصاء بالكامل يدعم اللغة ( العربية - الإنجليزية ) 3- تعديل وظيفة allValue لتعود بي 3D Array القيمة والبيانات ونوعها 4- تعديل وظيفة value لتعود بي 2D array البيانات ونوعها 5- إضافة وظيفة allKeysDict - [Get Property] لتعود بالمفاتيح الفرعية داخل قاموس 6- إضافة وظيفة allValuesDict - [Get Property] لتعود بالقيم الموجودة في مفتاح داخل قاموس 7- إضافة وظيفة IsKeyExists لتعود بنعم إذا كان المفتاح موجود (تم إضافة الـ Api الخاص بها) 8- إضافة وظيفة IsValueExists لتعود بنعم إذا كانت القيمة موجودة 9- التعديل علي بعض الأكواد وإضافة وظائف أخري (قد نأتي لذكرها لاحقاً "إن شاء الله" شرح لمثال واحد [ كتابة قيم داخل الريجيستري ] باقي الأمثلة موجودة بالملف Public Sub Test_awsReg_WriteValues() Dim winReg As awsReg Dim sPath As String Dim sValue As String Dim vResult As Variant On Error GoTo ErrorHandler sPath = "Software\awsApp" ' awsApp Doesn't Exist Yet Set winReg = New awsReg With winReg .useDebug = debugState .useMsgLog = msgLogState .MsgLanguage = englishMsg .Root = HKEY_CURRENT_USER .key = sPath ' REG_SZ Writing a string value .value("MyString") = "Hello, World!" .value("Date") = Format(Now, "yyyy-mm-dd hh:nn:ss") .value("awsPath") = "%USERPROFILE%\Documents" ' REG_DWORD Writing a numeric value [0 For False] [1 For True] .value("isValid") = CInt(1) .value("myNumber") = 2341 .Options = StoreNumbersAsStrings 'this to store numbers as String .value("strNumer") = 5246 ' REG_MULTI_SZ Writing an array (multi-string value) Dim myArray(2) As String myArray(0) = "Value1" myArray(1) = "Value2" myArray(2) = "Value3" .value("MyArray") = myArray Debug.Print "Values written successfully" End With ExitAndClean: If Not winReg Is Nothing Then Set winReg = Nothing Exit Sub ErrorHandler: MsgLog "We Received an unknown Error" & vbCrLf & _ "Error Number : " & Err.Number & vbCrLf & _ "Description : " & Err.description _ , llCritical, debugState, msgLogState, "Unknown Error" Resume ExitAndClean End Sub النتيجة : الأخوة الكرام الكود متاح للجميع نسعد بتعديلاتكم ومشاركتكم وإستفساركم بالتوفيق winRegApi_V1_FN.zip

السلام عليكم اولا هؤلاء الصف السادس وليس الخامس مشكلتك في مواد الرسوب .. شرط الدالة الا يكون هناك مواد رسوب .. والطلاب راسبون في جميع المواد مؤكد الدالة الخاصة بمواد الرسوب funFailMates بحاجة الى اعادة قراءة احتمال يوجد حقل تسمية مادة تم تغييره المسألة بحاجة الى وقت للتتبع

لا أعلم ما تحاول فعله لاكن جرب وضع الكود التالي في Module Public Sub RunCode() Dim WS As Worksheet, dest As Worksheet Dim tmp As Double, cell As Range Set WS = ThisWorkbook.Sheets("الادخال") Set dest = ThisWorkbook.Sheets("البيانات") tmp = WS.Range("C5").Value If IsNumeric(tmp) And tmp <> 0 Then On Error Resume Next Set cell = dest.Range("A2:A" & _ dest.Rows.Count).Find(tmp, LookIn:=xlValues, LookAt:=xlWhole) On Error GoTo 0 If Not cell Is Nothing Then cell.Offset(0, 19).Value = Date End If End If End Sub وفي حدث ThisWorkbook Private Sub Workbook_Open() Application.OnKey "{F10}", "RunCode" End Sub '==================== Private Sub Workbook_BeforeClose(Cancel As Boolean) Application.OnKey "{F10}" End Sub بهذه الطريقة بعد إظافة رقم الإدخال يمكنك تشغيل الكود باستخدام زر F10 فقط من لوحة المفاتيح (يمكنك تعيدله بما يناسبك ) ولا يستجيب أثناء التنقل أو تحديد خلايا أخرى 2.xlsm

أخي سامر ، دائماً ما نوجه الأخوة الذين يصادفهم مشاكل ألى ضرورة بناء الجداول بشكل سليم وصحيح ، وفي حالة مشروعك لا يسعني إلا تقديم المساعدة في الجزء الأول فقط . التعديل الذي رأيته صحيحاً بالنسبة لي ما يلي :- مصدر بيانات الكومبوبوكس المحول منه = رقم المخزن1 = سليم مع إضافة كود لتحديث الكومبوبوكس المحول اليه ( التوضيح لاحقاً ) مصدر بيانات الكومبوبوكس المحول اليه = رقم المخزن المحول اليه = مع إضافة شرط لإستعلام مصدر بياناته بحيث تم إضافة شرط في الحقل رقم المخزن كالآتي :- <>[Forms]![نموذج1]![المحول منه] بحيث يتم عرض المخازن التي ليست في المخزن المحول منه . الملف بعد التعديل Transfer (1).accdb وأضف على ما سلف ، هذا استعلام يعطيك اجمالي الكمية الواردة والمنصرفة لكل صنف حسب المخزن ، وطبعاً الشروط تستطيع إدارتها كما هي حاجة مشروعك ، قم بإنشاء استعلام جديد وألصق الكود التالي فيه ، واختر المخزن 1 أو 2 SELECT [حركة صنف].[رقم الصنف], Sum([حركة صنف].[الكمية الواردة]) AS إجمالي_الواردة, Sum([حركة صنف].[الكمية المنصرفة]) AS إجمالي_المنصرفة, الاصناف.[اسم الصنف] FROM الاصناف INNER JOIN [حركة صنف] ON الاصناف.[كود الصنف] = [حركة صنف].[رقم الصنف] WHERE ((([حركة صنف].[رقم المخزن2])=[Forms]![نموذج1]![المحول منه])) GROUP BY [حركة صنف].[رقم الصنف], الاصناف.[اسم الصنف];

https://excelnoob.com/vba-password-remover/

أخي الكريم @Foksh الأخوة الكرام صبحكم الله بالخير 1- إلغاء وتفعيل الحماية الخاصة بـ application.FollowHyperlink 2- إضافة مسار البرنامج لـالــ Access\Security\Trusted Locations 3- يعتبر الرجستري وسيط بين الوجهات المتعددة مثال 1 : أعمل بكود لضبط وتحجيم أبعاد الاكسيس والتعامل مع أكثر من شاشة بحيث يسمح للمستخدم بعرض البرنامج علي الشاشة 1 او 2 إن كان متصل بالجهاز أكثر من شاشة وإن كانت الابعاد مختلفة تختلف أبعاد البرنامج وهو يعتمد علي الجداول بشكل أساسي وإن كان هناك أكثر من واجهة تحتاج إلي تطبيق الامر علي كل واجهة ولكن الريجيستري يعتبر وسيط يسمح لك بتمرير القيم وإستدعائها وتعين قيم افتراضية مثال 2 : يمكن إستخدامة في حماية البرنامج الخاص بك فإضافة قيم في الريجيستري تسمح لك بالتحقق من - متي أول مرة تم إستخدام البرنامج (للمدة التجريبة) - إضافة مفاتيح خاصة بكل جهاز - الأفكار كثيرة أظن كدا فكرة الوساطة واضحة وأتمني أسمع أفكاركم 🧠 4- إستدعاء بعض المعلومات التي تحتاج إليها مثل - معرفة مسار النظام الافتراضي [ HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion ] - معرفة جميع الطابعات الموجودة [ HKEY_LOCAL_MACHINE\SYSTEM\CurrentControlSet\Control\Print\Printers ] - معرفة الطابعة الإفتراضية [ HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows ] ثم [ Device ] 5 - تغير الإعدادات - تغير الطابعة الإفتراضية - عدم السماح للوندوز بتجاوز إختيار - فيما أذكر يمكن التحكم بالطابعة الإفتراضية من خلال الريجيستري كعمل بروفايل خاص بإعدادات خاصة أرجو لكم التوفيق والسداد والتعامل مع الريجيستري بحذر ويفضل دائماً أخذ نسخة احتياطية للأمان

وعليكم السلام ورحمة الله وبركاته.. ما يجب التحقق منه عدة نقاط ، أذكر منها :- 1. تحقق من لغة الـ Unicode في الويندوز . 2. تنسيقات الوقت والتاريخ في الويندوز . 3. نسخة الأوفيس وإصدارها . 4. بعد النقطة 3 اذا كان الملف مفتوح المصدر قم بضغط وإصلاح القاعدة على نفس الجهاز . 5. الأصل و قبل هذا كله ، التأكد من سلامة قاعدة البيانات والتنسيقات لهذه العناصر ( مربعات النص ) ومصادر بياناتها في الجداول . 💡 هذا من وجهة نظري والله أعلم.

وعليكم السلام ورحمة الله تعالى وبركاته جرب هدا Option Explicit Dim PassProtect As String, OnRng As Range Private Const Clé As String = "1234" Public Property Get WS() As Worksheet: Set WS = Sheets("Sheet1"): End Property Sub Data_Protection() Dim linge As Variant Do linge = Application.InputBox("أدخل رقم الصف الأخير لقفل الخلايا", Type:=1) If linge = False Then Exit Sub If Not IsNumeric(linge) Or linge < 1 Or linge > WS.Rows.Count Then: MsgBox "خطأ في الإدخال" Exit Do Loop Application.ScreenUpdating = False Application.Calculation = xlCalculationManual ' قم بتعديل النطاق بما يناسبك Set OnRng = WS.Range("A2:M" & linge) With WS If .ProtectContents Then .Unprotect password:=Clé .Cells.Locked = False OnRng.FormulaHidden = True OnRng.Locked = True .Protect password:=Clé End With Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox linge & ":" & "تم قفل الحسابات بنجاح لغاية الصف ", vbInformation End Sub '======================================================================= Sub Data_UnProtection() Dim result As VbMsgBoxResult Do PassProtect = InputBox("أدخل كلمة المرور لفك الحماية") If PassProtect = "" Then Exit Sub If PassProtect = Clé Then Application.ScreenUpdating = False Application.Calculation = xlCalculationManual WS.Unprotect password:=Clé WS.Cells.Locked = False WS.Cells.FormulaHidden = False Application.ScreenUpdating = True Application.Calculation = xlCalculationAutomatic MsgBox "تم فتح جميع الحسابات بنجاح", vbInformation Exit Sub Else result = MsgBox( _ "كلمة المرور غير صحيحة" & vbNewLine & "هل ترغب في المحاولة مرة أخرى؟", _ vbCritical + vbYesNo, "خطأ في كلمة المرور") If result = vbNo Then MsgBox "تم إلغاء العملية", vbInformation Exit Sub End If End If Loop End Sub غلق المدى المحدد .xlsb

أهلاً مهندسنا الغالي .. بدايةً صدقاً ليس تعدياً ولكن كانت فكرتي ان يتم انشاء استعلام مبني على استعلام فرعي بحيث عند الفلترة على سبيل المثال في المرفق الذي وضعه أخونا غسان - ( مع إنه فارغ ولا بيانات ) وجزاك الله خيراً على طرحك للبيانات - يتم الترقيم حسب القيم الموجودة في الاستعلام النهائي . لذا في مديول بسيط نضع الكود التالي :- Dim Counter As Long Function GetSequentialNumber() As Long Counter = Counter + 1 GetSequentialNumber = Counter End Function وقمت بانشاء نموذج بسيط يحتوي مربع نص كمثال على الفلترة بالتاريخ في الحقل "تاريخ المباشرة" وزر لتنفيذ الأمر بأن يتم انشاء استعلام ( داخلي ) واستعلام مبني على الاستعلام الداخلي لعد السجلات وإدراج الترقيم التسلسلي في حقل جديد . في الزر ، وضعت هذا الكود ليقوم بالمهمة :- Dim db As DAO.Database Dim qdf As DAO.QueryDef Dim sql As String Dim userCriteria As String Dim whereClause As String If Not IsNull(Me.Txt_Date) And Trim(Me.Txt_Date) <> "" Then userCriteria = Trim(Me.Txt_Date) whereClause = "WHERE M.[تاريخ المباشرة] = '" & Format(dateValue(userCriteria), "dd-mm-yyyy") & "'" Else whereClause = "" End If sql = "SELECT (SELECT COUNT(*) FROM Table1 AS T " & _ "WHERE T.ID IN (SELECT ID FROM Table1 AS M " & _ whereClause & " ) AND T.ID <= M.ID) AS [رقم تسلسلي], " & _ "M.ID, M.[اسم الموظف], M.[اسم الدائرة], " & _ "M.[تاريخ المباشرة], M.[العنوان الوظيفي], " & _ "M.[الدرجة الوظيفية] " & _ "FROM Table1 AS M " & _ whereClause & ";" Set db = CurrentDb On Error Resume Next db.QueryDefs.Delete "Foksh" On Error GoTo 0 Set qdf = db.CreateQueryDef("Foksh") qdf.sql = sql qdf.Close DoCmd.OpenQuery "Foksh" حيث يتم انشاء استعلام داخلي ( مع أو بدون المعيار ) ، ثم يتم انشاء استعلام جديد Foksh ويتم فتحه ليتم ترقيم السجلات بتسلسل حسب عددها وليس حسب رقمها في الجدول . الملف المرفق : Ghassan - 1.accdb

وعليكم السلام أخي غسان .. مع أن الملف بدون بيانات ولكن عبأته لك ببيانات عشوائية .. وطبقت عليه فكرة والدنا العزيز @ابوخليل 🙂 والدور على معلمنا الحبيب @Foksh ليطبق فكرته 😊👌 ghassan.accdb

على اعتبار اسم الجدول tbl1 وهذا الجدول يحتوي على ترقيم تلقائي اسمه id ادرج ضمن الاستعلام الحقل id والصق في حقل جديد في الاستعلام هذا السطر : urAoutoNm: DCount("ID";"tbl1";"ID <=" & [ID])

اخي الفاضل أنا آسف علي الرد بسبب النت انظر في هذا الملف البحث وتعديل درجات.rar