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

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

Popular Content

Showing content with the highest reputation since 21 مار, 2024 in all areas

  1. استاذ @gavan من وجهة نظري كل البرامج تعتمد على تقسيم القاعدة . فأنت هنا بالاكسس يمكنك تقسيم القاعدة أماميه وبها (الاستعلامات والنماذج و التقارير و الموديلات و الوحدات النمطية)، والقاعدة الخلفية وبها الجداول وممكن تقسم القاعدة الخلفية كمان مجموعة جداول بقاعدة والمجموعة الباقية بقاعدة أخرى والربط بين القاعدة الأمامية والقواعد الخلفية بالطريقة السليمة . تحياتي .
    5 points
  2. السلام عليكم ورحمة الله وبركاته اخواني الكرام.. قرأت أكثر المواضيع التي تتعلق بموضوع الباركود والـ QR . إلا انني أبحث عن شيء محدد ، ولا أخفيكم أنني حاولت ابتكار فكرة تعمل بشكل عكسي تقوم على مبدأ أنه عند قراءة الباركود داخل آكسيس يقوم بإدراج البيانات من الباركود الى مربعات نص محددة. على سبيل المثال ( تمت التجربة على QR ):- ( رقم المريض ، اسم المريض ، رقم الهاتف ، العمر ) هذه المعلومات تمت إضافتها في QR وانشاء صورة . المطلوب أنه عند قراءة هذا الـ OR في النموذج ان يتم ادراج القيم في مربعات النص التي يتم تحديدها ( علماً بأن النموذج هذا ليس له مصدر بيانات جدول او استعلام وغير مطلوب حفظ القيم داخل اي جدول . وهذه صورة QRتحتوي العديد من البيانات للتجربة لم أقم بارفاق ملف لأنني رغبت بان يكون الموضوع مفتوح بأكثر من اتجاه وليس ضمن فكرة محددة . المطلوب :- طريقة تجعلني عند قراءة الباركود ان يتم ادراج البيانات التي يحملها في مربعات نص محددة !!
    4 points
  3. السلام عليكم ورحمة الله وبركاته أسعد الله أوقاتكم بكل خير وسرور .. وتقبل الله منا ومنكم صالحات الأعمال .. 😊🤲🏻 يطيب لي أن أقدم لكم هذا الهدية المتواضعة بمناسبة هذا الشهر الفضيل 🙂🌼🎁 استبدل الرسائل العادية في أكسس برسائل ذات تصاميم قمة في الإبداع وبمميزات إضافية . من مميزات هذه الرسائل: - تصميم جميل وألوان جذابة. - خاصية ذاتية الاختفاء. - عنوان رئيسي + عنوان فرعي - تحكم بالنص ( عربي - إنجليزي ) ( توسيط - محاذاة على اليمين أو اليسار) - سهلة الاستخدام . الشرح على اليوتيوب : التحميل 🙂 Moosak MsgBox.accdb ولا تنسوني من صالح دعواتكم 😊🌷🌼🌹
    4 points
  4. Dim db As DAO.Database Dim rs As DAO.Recordset Dim fld As DAO.Field Dim searchNumber As Long Dim found As Boolean searchNumber = Me.C Set db = CurrentDb() Set rs = db.OpenRecordset("SELECT Salary.GradeNO, Salary.[1], Salary.[2], Salary.[3], Salary.[4], Salary.[5] FROM Salary ORDER BY Salary.GradeNO DESC;", dbOpenDynaset) i = 0 found = False Do Until rs.EOF For Each fld In rs.Fields If Not IsNull(fld.Value) And fld.Value = searchNumber Then found = True ElseIf found And Not IsNull(fld.Value) And i < Me.D And fld.Name <> "GradeNO" Then i = i + 1 Me.G = fld.Value Me.E = rs!GradeNO Me.F = fld.Name End If Next fld rs.MoveNext Loop rs.Close Set rs = Nothing Set db = Nothing
    4 points
  5. استكمالا لكيفية التحديث بطريقة أخرى بعد الشكر لمساعدتكم في طرح الأفكار سوف أقدم لكم هذه الطريقة وقبل البدأ اريد ان أنوه على بعض الردود حول الجداول في قاعدة البيانات هل أقوم بإعادة ربطها بعد التحدث والجواب هو (لا) وذلك عند تحديث البرنامج اقوم بإعادة ربطها من جهاز المطور وكل أجهزة المستخدمون والسيرفر وجهازي اللي أطور البرنامج عليه مرتبطة بشبكة محلية داخل الشركة وبعد التحديث وعند تركيب البرنامج على أي جهاز فإن الجداول تتصل بقاعدة البيانات مباشرة . سوف أشرح الفكرة باختصار المتطلبات 1- جدول جديد يضاف في البرنامج مرتبط بقاعدة البيانات مباشرة يحتوي على حقل رقم النسخة 2- تصميم نموذج افتتاحي مصدره الجدول السابق 3- تصميم برنامج مساعد نسميه (Update.accdb ) ونضعه في مجلد البرنامج 4- مجلد مشاركة موجود على السيرفر نضع فيه البرنامج المحدث شرح خطوات البرنامج عند التحديث 1- عند اكتمال التحديث يضاف رقم النسخة الجديدة في النموذج على سبيل المثال (002) في النموذج الافتتاحي و في الجدول رقم النسخة 2-عند التشغيل يقوم البرنامج بمقارنة النسخة المخزنة في الجدول مع جدول حقل النسخة ، سوف يجد الاختلاف وتظهر رسالة يوجد تحديث 3- يغلق البرنامج (الاصدار القديم) ويفتح البرنامج المساعد 4- عند فتح البرنامج المساعدة يقوم بحذف النسخة القديمة ويستدعي النسخة الجديدة من مجلد المشاركة على السيرفر ويلصقها في نفس مجلد البرنامج بدل النسخة القديمة التفاصيل من المعروف أن البرنامج سوف يكون على الهاردسك ( C ) عند جميع المستخدمون في المجلد (Shaoon) وأيضا البرنامج المساعد (Update.accdb) وملحقات البرنامج مثل أيقونة البرنامج او ملفات التعليمات وغيرها 👇 النموذج الافتتاحي في البرنامج عند المستخدم ذو الاصدار 001 👇 النموذج الافتتاحي في البرنامج الوسيط ( Update.accdb ) 👇 انتهى الشرح في المرفق الشرح العملي ملاحظة هامة : عند تنزيل الشرح العملي فك الضغط وضع الثلاثة المجلدات في البارتشن (C) مباشرة ومن ثم الدخول على المجلد (Shaoon) وتشغيل البرنامج (Shaoon.accdb) Program.rar
    4 points
  6. وعليكم السلام ورحمة الله نعالى وبركاته اظن انه يجب عليك اولا تغيير مكان خلية اختيار اسم المادة (N1) خارج نطاق البحث لانه في حالة تم اخفاء عمود مادة الدين مثلا عمود (N) سيتم اخفاء خلية الاختيار لنفترض ان الخلية المحددة هي (R1) Private Sub Worksheet_Change(ByVal Target As Range) If Not Intersect(Target, Target.Worksheet.Range("R1")) Is Nothing Then Dim x As Range, rng As Range Set x = Clé([R1], [G7:P7]): Set rng = Columns("E:F") Application.ScreenUpdating = False If x Is Nothing Then MsgBox "مادة" & " " & [R1] & " : " & " غير موجودة ", vbExclamation: Exit Sub Columns("C:P").EntireColumn.Hidden = True x.EntireColumn.Hidden = False: rng.EntireColumn.Hidden = False ActiveWindow.ScrollColumn = 1 End If End Sub Function Clé(a, b As Range) As Range Dim i& On Error Resume Next i = WorksheetFunction.Match(a, b, 0) If i Then Set Clé = b(i) End Function اظهار الاعمدة Sub Show_all_columns() Sheets("Sheet1").Columns("C:P").EntireColumn.Hidden = False End Sub بطريقة اخرى Sub Hide_columns() Dim Clé As Variant, desWS As Worksheet, rng As Range Set desWS = ThisWorkbook.Sheets("Sheet1"): Clé = [R1].Value If Clé > 0 Then With desWS Set rng = .Rows(7).Find(Clé, LookIn:=xlValues, lookat:=xlWhole) If Not rng Is Nothing Then Application.ScreenUpdating = False .Columns("C:P").EntireColumn.Hidden = True rng.EntireColumn.Hidden = False .Columns("E:F").EntireColumn.Hidden = False Else MsgBox "مادة" & " " & Clé & " : " & " غير موجودة ", vbExclamation: Exit Sub End If End With End If ActiveWindow.ScrollColumn = 1 Application.ScreenUpdating = True End Sub صفحة الرصد V2.xlsm
    3 points
  7. وعليكم السلام ورحمة الله تعالى وبركاته لجلب الصور دفعة واحدة يكفي الوقوف بمؤشر الماوس على اول خلية فارغة على عمود الصور وتشغيل الكود التالي مع تحديد الصور المرغوب اظافتها Sub InsertMultiplePictures() 'اظافة الصور' Set WS = Sheets("ادخال البيانات") Dim Pictures() As Variant Dim j As String, Rng As Range, Cpt As Shape On Error Resume Next Pictures = Application.GetOpenFilename(j, MultiSelect:=True) a = Application.ActiveCell.Column If IsArray(Pictures) Then Col = Application.ActiveCell.Row For lLoop = LBound(Pictures) To UBound(Pictures) Set Rng = Cells(Col, a) Set Cpt = WS.Shapes.AddPicture(Pictures(lLoop), msoFalse, msoCTrue, Rng.Left, Rng.Top, Rng.Width, Rng.Height) Col = Col + 1 Next End If End Sub لافراغ عمود الصور Sub DeleteImage() Dim pic As Picture Set f = Sheets("ادخال البيانات") For Each pic In WS.Pictures If Not Application.Intersect(pic.TopLeftCell, f.Range("G6:G200")) Is Nothing Then pic.Delete End If Next pic End Sub الجدول 1 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$10;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture الجدول 2 =INDEX('ادخال البيانات'!$B$6:$G$2000;MATCH('طبع البيانات'!$C$36;'ادخال البيانات'!$B$6:$B$2000;0);6) =MyPicture2 واخيرا ربط الصور بالنطاق الجمعيه الخيريه 2.xlsb
    3 points
  8. وعليكم السلام ورحمة الله تعالى وبركاته Private Sub TextBox1_Change() Dim a As Variant, b As Variant, Clé$, Rng As Range, i&, j&, k&, m& Dim WS As Worksheet: Set WS = Worksheets("donnes") Dim desWS As Worksheet: Set desWS = Worksheets("search") Clé = "*" & desWS.[B3].Value & "*" Set Rng = desWS.Range("A6:G" & Rows.Count) a = WS.Range("D5", WS.Range("J" & Rows.Count).End(3)).Value If Me.TextBox1 = "" Then Rng.ClearContents Else Application.ScreenUpdating = False With desWS On Error Resume Next .AutoFilterMode = False ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2)) For i = 1 To UBound(a, 1) For j = 1 To UBound(a, 2) 'Filter by Uppercase and lowercase letters If LCase(a(i, j)) Like Clé Or UCase(a(i, j)) Like Clé Then k = k + 1 For m = 1 To UBound(a, 2) b(k, m) = a(i, m) Next Exit For End If Next Next Rng.ClearContents: Range("A6").Resize(k, UBound(b, 2)).Value = b Range("d6:d" & Rows.Count).NumberFormat = "dd-mm-yyyy" End With End If Application.ScreenUpdating = True End Sub بحث VBA V2.xlsm
    3 points
  9. شكرا لك استاذ حسان على الشرح الوافي الكافي و هي فكرتك الأولى ولعلك نسيت اضافة الجدول المحلي ضمن واجهة المستخدم لأن كتابة المقارنة بهذه الطريقة ستعمل لمرة واحدة فقط : 'يتأكد هل فيه نسخة مختلفة If Me.VerNo <> "001" Then ' =====> في كل مرة تقوم بتحدسث النسخة يجب تعديل الاصدار هنا وفي حقل الجدول xVer MsgBox "يوجد اصدار أحدث", 48 + 524288, "تحديث النسخة" واذا سمحت لي باضافة صغيرة : الجدول xver هذا على قاعدة البيانات في السيرفر وهو من سيحمل الرقم الجديد و يوجد جدول (محلي) على واجهة المستخدم يحمل الرقم القديم عند فتح واجهة المستخدم يقارن بين الرقمين في الجدولين .. فإن اختلفا يتم تشغيل التحديث ...... ويتم ايضا تحديث الجدول المحلي بالرقم الجديد /// وبما ان النسخة جديدة يكون المطور هو من وضع الرقم الجديد في الجدول المحلي فلا حاجة للتحديث . ليصبح كود المقارنة بما يشبه هذا : If VerNo1 <> VerNo2 Then
    3 points
  10. مشاركة مع الاخ @Foksh Option Compare Database Option Explicit Private Sub Command0_Click() ExecuteIfChromeOpen End Sub Function IsChromeRunning() As Boolean Dim strCommand As String Dim strOutput As String Dim objWShell As Object Set objWShell = CreateObject("WScript.Shell") strCommand = "tasklist /FI ""IMAGENAME eq chrome.exe""" strOutput = objWShell.Exec(strCommand).StdOut.ReadAll If InStr(strOutput, "chrome.exe") > 0 Then IsChromeRunning = True Else IsChromeRunning = False End If Set objWShell = Nothing End Function Sub ExecuteIfChromeOpen() If IsChromeRunning() Then MsgBox " المتصفح كروم قيد التشغيل. سيتم تنفيذ الأمر", vbInformation, "تأكيد" DoCmd.OpenForm "البيانات" Else MsgBox "يجب فتح المتصفح .", vbExclamation, "المتصفح مغلق" End If End Sub واليك المرفق بالتوفيق Database313.accdb
    3 points
  11. وعليكم السلام ورحمة الله وبركاته تفضل لعله لطلبك الراتب الاساسى212 مارس.xlsx
    2 points
  12. السلام عليكم مشاركه مع اخى @محمد احمد لطفى جزاه الله خيرا Private Sub x_Click() Call searchtext(Forms![fxm], Me.x) End Sub Sub searchtext(frm As Form, strtxt As String) Dim ctl As Control For Each ctl In frm.Controls If ctl.ControlType = acOptionButton Then If ctl.Name = strtxt Then ctl.Value = True Else ctl.Value = False End If End If Next End Sub testc_1.accdb
    2 points
  13. فقط قم باخفاء المربع الاصلى الصفر في التقرير.mdb
    2 points
  14. تفضل هل هذا ما تريد Dim a As String a = Me.x If Me.x = a Then Forms("fxm").Controls(a).Value = True End If أو If Me.x <> "" Then Forms("fxm").Controls(Me.x).Value = True End If testc.accdb
    2 points
  15. في موضوع الحسابات انا اعتمد على جعل القيمة الإفتراضية للحقول الرقمية في الجداول الأساسية = 0 ، لتلافي الوقوع في هذا الخطأ . فينتج دائماً في حال عدم وجود قيم في النماذج بأن يتم تخزين القيمة 0 في الحقول والتي هي مصدر للإستعلامات والتقارير والعمليات الحسابية في النماذج .... الخ . على العموم ملف الأخ ازهر عبد العزيز للإستعلامات يعمل بدون مشاكل وجميع الحقول الفارغة قيمتها = 0
    2 points
  16. مشاركة مع الأستاذ @محمد احمد لطفى .. اخي الكريم الأخطاء بسيطة ، فمثلاً الأمر Exit Sub يجب وضعها قبل اغلاق الجملة الشرطية لا بعدها ، ثم جملة فتح النموذج غير صحيحة والصحيح يصبح كالآتي :- If Me.aa = 1 Then GoTo oo Else MsgBox "يجب كتابة رقم صحيح" Exit Sub End If oo: DoCmd.OpenForm "bb" End Sub لاحظ الفروقات لتتضح الصورة عندك 😊
    2 points
  17. متألق ما شاء الله عليك أخي @hassan123 🙂 .. أفكار إبداعية جديدة 😄👌 ملاحظات وأفكار 🙂 : 1 - لاحظت أنك أدرجت ملف التحديث من ضمن الملفات ولا أضنك ستحتاج إليه بعد الآن مع التحديث الجديد 🙂 : 2 - للفائدة يمكنك الاستغناء عن الملف الذي يقوم بعملية التحديث والاستعاضة عنه بملف VBS أو ملف CMD وذلك لتجنب مشكلة الحاجة لتوثيق ملف الأكسس قبل فتحه .. فقد جربت هذه الطريقة سابقا و واجهتني مشكلة أن المستخدمين الذين لم يسبق لهم فتح ملف التحديثات ولم يتم توثيقة تقف عندهم عملية التحديث بسبب هذا الأمر .. وهذا الكود الذي أستخدمه أنا لغرض إنشاء ملف ال VBS يمكنك الاستفادة من إن أحببت 🙂 : ' Updater VBS File Path dim UpdaterFilePath UpdaterFilePath = CurrentProject.Path & "\Updater.VBS" ' ************************************************** delete Old Updater File If Len(Dir(UpdaterFilePath, vbDirectory)) > 0 Then Kill (UpdaterFilePath) End If ' ************************************************** Write The VBS File Which Updates The DB Dim FSO Set FSO = CreateObject("Scripting.FileSystemObject") Dim oFile dim txtOldFEPath dim txtNewFEPath txtOldFEPath = "E:\Open DB\الملف المصدر.accdb" txtNewFEPath = "E:\Open DB\الملف الهدف.accdb" ' Creat vbs File with ANSI Coding ' الترميز الذي يدعم العربية Set oFile = FSO.CreateTextFile(UpdaterFilePath, True, False) oFile.WriteLine "Dim fs, strCopyFrom, strCopyTo" oFile.WriteLine "Set fs = CreateObject(""Scripting.FileSystemObject"")" ' Start writing The Updater File ' sleep 3 seconds oFile.WriteLine "Dim SecWait" oFile.WriteLine "SecWait = DateAdd(""s"", 3, Now())" oFile.WriteLine "Do Until (Now() = SecWait)" oFile.WriteLine "Loop" ' copy files oFile.WriteLine "strCopyFrom = " & """" & txtNewFEPath & """" oFile.WriteLine "strCopyTo = " & """" & txtOldFEPath & """" oFile.WriteLine "fs.CopyFile strCopyFrom, strCopyTo, True" ' open the new version oFile.WriteLine "CreateObject(""Shell.Application"").Namespace(0).ParseName(strCopyTo).InvokeVerb ""Open""" oFile.WriteLine "Set fs = Nothing" oFile.Close Set FSO = Nothing Set oFile = Nothing ' ************************************************** Open the VBS Updater File Shell "explorer.exe" & " " & UpdaterFilePath, vbMinimizedNoFocus ' ************************************************** Close FE Database Application.Quit 3- أزيدك من الشعر بيت 😄 .. هذا كود لإضافة ملف التحديثات الجديدة لحقل المرفقات في الجدول بطريقة سهلة ( يفتح مستعرض الملفات >> تختار ملف التحديث >> وتم بحمد الله ) 🙂 Option Compare Database Option Explicit Public Sub AddAttacmentToTable(TableName As String, AttachmentFieldName As String, IDField As String, IDvalue As Long) 'TableName = اسم الجدول 'AttachmentFieldName = اسم حقل المرفقات 'IDField = اسم حقل الآيدي 'IDvalue = رقم الآيدي On Error GoTo HandleError Dim db As DAO.Database Dim rs As DAO.Recordset Dim attachFld As DAO.Recordset Dim file As String file = selectFile Set db = CurrentDb Set rs = db.OpenRecordset("select * from " & TableName & " where " & IDField & " = " & IDvalue & ";") ' Or OpenRecordset("TableName") ' Debug.Print "select * from " & TableName & " where " & IDField & " = " & IDvalue & ";" If Not rs.BOF And Not rs.EOF Then rs.MoveFirst rs.Edit Set attachFld = rs.Fields(AttachmentFieldName).Value attachFld.AddNew attachFld.Fields("FileData").LoadFromFile file attachFld.Update rs.Update End If MsgBox "done" rs.Close Set db = Nothing Set rs = Nothing HandleExit: Exit Sub HandleError: If Err.Number = 0 Then Exit Sub Else MsgBox Err.Number & vbNewLine & vbNewLine & Err.Description End If Resume HandleExit End Sub Public Function selectFile() ' دالة مستعرض الملفات On Error GoTo ErrHandler Dim fd As Object Dim filedialogPath As String Set fd = Application.FileDialog(1) fd.AllowMultiSelect = False fd.Title = "حدد الملف المطلوب" ' fd.InitialFileName = CurrentProject.Path fd.Filters.Clear fd.Filters.Add "كل الملفات", "*.*" If fd.Show = True Then selectFile = fd.SelectedItems(1) ' Exit Function Else MsgBox "لم تقم باختيار أي ملف" Exit Function End If ErrHandler: If Err.Number = 0 Then Exit Function Else MsgBox "Error Number : " & Err.Number & " :::: " & Err.Description ' End If End Function Sub testing() 'للتجربة AddAttacmentToTable "att", "Att_T", "ID", 4 End Sub مع تمنياتي لك بالتوفيق 🙂
    2 points
  18. السلام عليكم الاخ مازن بياناتك عبارة عن اعمدة ونحن بحاجة الى عرضها بشكل افقي انظر الى العمل بالترتيب خطوة خطوة كما ابينه بالشرح لك ، من اجل تفهم طريقة العمل 1- استعلام query1 تم فيه تجميع الحالات حسب الرتبة 2- استعلام جدولي لنشر البيانات وتوزيعها مصدره query1 وبما ان الاستعلام الجدولي صامت لا يمكن التعامل مع حقوله عند العرض استخدمنا جدول مؤقت وسيط يكون هو المصدر الاساسي للتقرير حيث يتم الحق بيانات الاستعلام الجدولي اليه بين فترة واخرى كلما تغيرت او زادت البيانات باستخدام زر ( اعداد التقرير ) لم افهم ما تعني بالمجموع الفعلي والمجموع الكلي لذا تركته لك يمكنك عمله بكل يسر --------------------------------------------------------- انا عملت على عرض جميع الحالات بالتفصيل ويمكنك ضم بعض الحالات مع بعضها افتح التقرير على التصميم وفي الخصائص انقر على النقاط الثلاث في مصدر بيانات التقرير سيعرض لك الاستعلام المصدر الذي يمكنك من خلاله اجراء جميع التعديلات كإنشاء حقول تجميع وضم بعضها الى بعض او حذف ما لا تريده . آمل ان يروق العمل لك قاعدة2.rar
    2 points
  19. اخوي مازن .. تصفحت المثال فتعجبت من طريقتك في استخلاص البيانات اعتقد لم يسبقك احد الى هذه الافكار في التقرير اولا : لماذا العشرات من مربعات التحرير .. وفي مصدر بيانات كل مربع عمليات عجيبة من التصفيات والمعايير كل هذا من اجل اخراج احصائية . المسألة ايسر واسهل من هذا بكثير ثانيا : لن تتقدم خطوة واحدة في تحصيلك البرمجي ما دامت هذه طريقة تصميمك للجداول (تسمية الجداول والحقول بحروف عربية / ترك مسافات خالية في التسميات ) الحروف العربية تكتب فقط في التسميات التوضيحية سوف تتعب كثيرا ولن تفهم الجمل البرمجية المكتوبة .. لأن الترتيب المنطقي للسطر يتداخل في بعضه ) ______________________________ انا هذا منهجي كمعلم .. النصيحة اولا ثم تأتي المساعدة لاحقا بالنسبة لطلبك لامانع لدي ان اخرج تقريرك كما تحب ولكن قبل هذا يجب ان اغير الحروف العربية في المصدر . وسترى الفرق بطريقة جديدة عليك ما رأيك ؟
    2 points
  20. كلامك سليم 100000 % ، كل العذر منك استاذنا @سامي الحداد ، ولكني فعلاً لم اقم بتجربة المرفق وكنت اتصفح من الجوال هذا دليل ان الواحد مع التعب يحس الاسلاك في مخه تعمل ماس
    2 points
  21. اضغط على قاعدة البيانات زر الماوس اليمين واختر UNLOCK .
    2 points
  22. الحــــــل : 1- تعديل الحقول من خصائص الجداول من مربع تحرير وسرد الى مربع نص 2- اعادة استدعاء حقل النص في خانة السرد والتحرير بالنموذج تحياتي اخي واستاذي @Moosak🌹 4444.accdb
    2 points
  23. السلام عليكم ورحمة الله وبركاته بالإضافة لما تفضل به الأستاذ موسى جزاه الله خيرا انا استخدم هذا البرنامج Universal Document Converter وهذا موقع الشركة: https://www.print-driver.com/download بعد إتمام عملية تنصيب البرنامج تابع الفيديو . ومرفق ملفك بعد التعديل. بالتوفيق jpg.rar شرج عمل برنامج Universal Document Converter.rar
    2 points
  24. تفضل تم تعديل النسخ بداية من الصف 10 اما بخصوص التنسيق في الصورة فوق ليس له اي علاقة بالبيانات الخاصة بك اظافة اخي الفاضل انت تشتغل على يوزرفورم بمعنى التعامل و الترحيل يكون على حسب البيانات الموجودة في الليست بوكس لا اقل ولا اكثر ملاحظة تمت اظافة المعادلة المقترحة من طرف الاخ إيهاب عبد الحميد في اخر مشاركة لك للتجربة مستخلصات الاعمال الجنوبية- V4.xlsm
    2 points
  25. السلام عليكم.. استاذ احمد...لماذا لا تعتمد سنوات الخدمة في احتساب الراتب عملت لك هذه الشفرة ..وهي شغالة بالنسبة (للبكلوريوس) لانها تبدأ من الدرجة السابعة فقط مرر سنوات الخدمة عبر startDate في الدالة Function IncreaseSalary(startDate As Double) As Double Dim years As Double Dim newSalary As Double years = startDate '7 If years <= 4 Then newSalary = 296 + ((years - 1) * 6) '6 ElseIf years > 4 And years <= 8 Then newSalary = 362 + ((years - 5) * 6) '5 ElseIf years > 8 And years <= 12 Then newSalary = 429 + ((years - 9) * 6) '4 ElseIf years > 12 And years <= 17 Then newSalary = 509 + ((years - 13) * 8) '3 ElseIf years > 17 And years <= 22 Then newSalary = 600 + ((years - 18) * 10) '2 ElseIf years > 22 And years <= 27 Then newSalary = 723 + ((years - 23) * 17) '1 Else newSalary = 910 + ((years - 28) * 20) End If IncreaseSalary = newSalary End Function
    2 points
  26. السلام عليكم تفضل الحل بالكود معادلة الى كود2.xlsm
    2 points
  27. ممكن يكون لها حل ... انتظر حتى اصل لجهازي او ممكن تجد اجابة من الاخوة الكرام
    2 points
  28. لتطبيق الصلاحيات على أي نموذج أكتب هذا السطر في حدث عند الفتح للنموذج : Private Sub Form_Open(Cancel As Integer) Call Permissions End Sub باب الإبداع مفتوح لكم 😉👌🏼 البرنامج شغال زي السكينة على الطحينة 👍🏻😄 قم بتأمين الملف وتمكين الماكرو أخي @abouelhassan موضوع الصلاحيات باب واااااااسع جدا جدا .. وهذا مجرد نموذج مبسط .. ويمكنك الإضافة عليه كما تحب 🙂👌🏻
    2 points
  29. ما شاء الله تبارك الرحمن 🙂 🌹 فكرة رائعة أخي حسان @hassan123 وهذا دليل على أنه لا حدود للإبداع في الأكسس 👌🏼 بالإضافة للنقطة التي ذكرها أستاذنا @ابوخليل ( وهي نقطة مهمة في نظري ) .. فقط أنبهك لموضوع الروابط للواجهة القديمة و ملف التحديث و رابط التحديث الجديد .. هذه الروابط لو تجعل الكود يتعرف على مواقعها بشكل أوتوماتيكي سيسهل عليك بعض الأمور ... منها : 1- في الجدول xVer أضف حقل لمكان وجود ملف التحديث وذلك للحصول عليه تلقائيا من الجدول وذلك لأنك قد ترغب مستقبلا في تغيير أسمه أو موقعه دون الحاجة لتغييره يدويا في الكود. 2- قد يتم تنصيب البرنامج على قرص آخر غير ال C لذلك إجعل تحديد مواقع التنصيب شيء من هذا القبيل : 'حذف البرنامج النسخة V001 Kill CurrentProject.Path & "\Shaoon.accdb" ' موقع نسخة البرنامج المحدثة Dim NewUpdatePath As String NewUpdatePath = DLookup("[NewUpdateFilePath]", "[xVer]") 'نسخ النسخة الجديدة002 ووضعها بدل النسخة التي انحذفت FileCopy NewUpdatePath, _ CurrentProject.Path & "\Shaoon.accdb" . . . . ...... <<تكملة الكود>> لاحظت بأنك قمت بربط التحديث الجديد بقاعدة البيانات قبل وضع التحديث موضع التنفيذ وهذا شيء جيد 👍🏻🙂
    2 points
  30. السلام عليكم ممكن أن لاتستخدم معادلات ولا أكواد الحالة دي ممكن استخدام الجداول المحورية Pivot Tables سريعة جدا حيث أنها خاصية جاهزة في الاكسل يعيبها نقطتين يمكن التغلب عليهما 1- أن بعد تحديث البيانات ، لايتم تحديث الجدول المحوري اوتوماتيكيا بل يجب أن تضغط كليك يمين عالجدول وتطلب تحديث 2- أنك لايمكن عمل الجدول المحوري إلا إذا كانت جميع الأعمدة التي تم اختيار البيانات بها لها عناوين وهذه العناوين غير متماثلة ، تجدني وضعت عناوين بالأحمر أنظر المرفق ، عدل أي بيانات ثم ضغط كليك يمين عالجدول وتطلب تحديث معادلة الى كود.xlsm
    2 points
  31. السلام عليكم مرفق الملف بعد تغير صيغة التنسيق الشرطي الأحمر إلي =AND(TODAY()>$I2,$K2="",ISBLANK($I2)=0) إنتهاء الرحصة222.xlsm
    2 points
  32. بعد امر الحذف استخدم الأمر Docmd.Requery ينفع
    2 points
  33. الله يبيض وجهك أخوي سامي الحداد ... ورحمك الله ووالديك ألف شكر لك يا عزيزي والشكر موصول للعزيز الغالي Foksh ايعمل بامتياز👍
    2 points
  34. متأسف جدا بشمهندس خليفة - الخطاء مني انا في المشاركة كتب العطلة الاسبوعية الخميس والجمعة والصحيح هي الجمعة والسبت ارجوك تقبل اعتذاري
    2 points
  35. تفضل استاذ @Abdelaziz Osman المرفق بعد التعديل حسب طلبك . اليك الشرح والمرفق . codeM-2.rar
    2 points
  36. وعليكم السلام ورحمة الله تعالى وبركاته Sub transfert() Dim desWS As Worksheet: Set desWS = Sheets("تجميع") Dim i As Byte, F As Variant Application.ScreenUpdating = False desWS.Range("a2:j" & Rows.Count).ClearContents For i = 1 To Worksheets.Count If UCase(Sheets(i).Name) <> desWS.Name Then With Sheets(i) F = .Range("A10:G10", .Range("a" & Rows.Count).End(xlUp)) desWS.[A65000].End(xlUp).Offset(2).Resize(UBound(F), 7) = F End With End If Next Application.ScreenUpdating = True End Sub في حالة الرغبة بتنسيق الجداول يمكنك اظافة الاسطر التالية اسفل الكود 'تنسيق الجداول '''*****تسطير***** With desWS lastrow = .Range("A:G").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row Set rngCell = .Range("A2 :G" & lastrow) For Each c In rngCell.Rows If WorksheetFunction.CountA(c) > 0 Then c.Borders.LineStyle = xlContinuous Next '''****تمييز رؤوس الاعمدة*** Set j = .Range("a2:a" & lastrow) For Each r In j If r.Value = "ر.ت" Then _ If rng Is Nothing Then Set rng = r.Resize(1, 7) Else Set rng = Union(rng, r.Resize(1, 7)) Next If Not rng Is Nothing Then rng.Interior.Color = RGB(204, 204, 255): rng.Font.Bold = True End With ListEleve_20240320 V2.xlsm
    2 points
  37. Sub TEST1() Dim WordApp As Object, objDoc As Object, Fname As Variant Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") WSdst.Cells.Clear Fname = Application.GetOpenFilename("Word Documents, *.doc*") If Fname = False Then Exit Sub On Error Resume Next Set WordApp = CreateObject("Word.Application") Set objDoc = WordApp.Documents.Open(Fname) WordApp.Selection.WholeStory WordApp.Selection.Copy WSdst.Range("A1").Select ActiveSheet.Paste With WSdst .Cells.EntireRow.AutoFit: .Columns("A:A").ColumnWidth = 15: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("B:E").ColumnWidth = 31 End With objDoc.Close False WordApp.Quit Set WordApp = Nothing Set objDoc = Nothing End Sub في حالة الرغبة باختيار صفحات معينة اليك الكود التالي Sub ImportWordTablesArray() Dim tables() As Variant Dim WordApp As Object, WordDoc As Object Dim arrFile As Variant, Filename As Variant Dim Table As Integer, iCol As Integer Dim iRow As Long, Cpt As Long, Counter As Long Dim WSdst As Worksheet: Set WSdst = ThisWorkbook.Sheets("word") On Error Resume Next arrFile = Application.GetOpenFilename("ملف وورد (*.doc; *.docx),*.doc;*.docx", 2, _ "اظافة الملف", , True) If Not IsArray(arrFile) Then Exit Sub Application.ScreenUpdating = False Set WordApp = CreateObject("Word.Application") WordApp.Visible = False WSdst.Cells.Clear '<- '<-افراغ البيانات السابقة For Each Filename In arrFile Set WordDoc = WordApp.Documents.Open(Filename, ReadOnly:=True) With WordDoc Table = WordDoc.tables.Count If Table = 0 Then MsgBox WordDoc.Name & "لا يحتوي على جداول", vbExclamation, "استيراد" End If tables = Array(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24) '<- '<- ارقام الصفحات For Counter = LBound(tables) To UBound(tables) With .tables(tables(Counter)) For iRow = 1 To .Rows.Count For iCol = 0 To .Columns.Count Cells(Cpt, iCol) = WorksheetFunction.Clean(.Cell(iRow, iCol).Range.Text) Next iCol Cpt = Cpt + 1 Next iRow End With Cpt = Cpt + 1 With WSdst .Cells.EntireRow.AutoFit: .Columns("A:b").AutoFit: '<- قم بتنسيق الورقة بما يناسبك .Columns("A:D").HorizontalAlignment = xlCenter: .Columns("c:e").ColumnWidth = 31 End With Next Counter .Close False End With Next Filename WordApp.Quit Set WordDoc = Nothing Set WordApp = Nothing End Sub WORD.rar
    2 points
  38. استاذ @2saad أولاً........... لماذا لم ترد على المشاركة السابقة لطلبك استخراج المحافظة من الرقم القومي والسن في أول اكتوبر ؟؟؟؟؟؟؟؟؟؟؟؟؟؟؟ ثانياً ........... بالنسبة لطلبك تطبيق الكود على الجدول (Data) ... الجدول به حقل الصورة (Attachment) فلايمكن عمل لها (Update) وسيخرج لك (Error) لذا استخدم الكود التالي .بالمرفق . قاعدة بيانات مدرسية (22).rar
    1 point
  39. بسم الله الرحمن الرحيم.. السلام عليكم ورحمة الله وبركاته.. بعد طول غياب عن الساحة بسبب ضروف الحياة والعمل.. اقدم لكم اداة صغيرة من برمجتي بلغة Visual Studio .NET تقوم بالتقاط الصور كاميرا الويب او اي كاميرا متصلة بالكومبيوتر ومن ثم خزنها في الجهاز الاداة قمت بربطها مع الاكسس، بحيث تقوم بتمرير براميتر من الاكسس الى الاداة وهذا البراميتر متمثل بـ مسار حفظ الصورة + واسم الصورة + صيغتها مثال: Dim SavedPath As String SavedPath = """" & CurrentProject.Path & "\Capture.png" & """" الاداة تستخدم مكتبات AForge للتحكم بالكاميرات. صورة الاداة: بمجرد ان تضغط زر Open Camera من الاكسس ستعمل الاداة مباشرة قم بترتيب الكاميرا الخاصة بك لاخذ لقطة مناسبة واضغط على الزر Snapshot ثم اضغط على الز save لحفظ الصورة. الاداة اخذت مني وقت 8 ساعات في البرمجة لذلك لا تنسوني ووالدي من صالح دعائكم. تم بحمد الله. SEMO_webCam.rar كلمات مفتاحية: التقاط صورة من الكاميرا، حفظ الصورة من الكاميرا، جلب الصورة من كاميرا الويب، جلب الصورة من الكاميرا وحفظها في قاعدة البيانات، حفظ الصور بقاعدة البيانات، خزن الصورة من الكاميرا كاميرا ويب قاعدة بيانات اكسس، اكسس كاميرا الويب، اكسس كاميرا، جلب الصورة من الكاميرا
    1 point
  40. السلام عليكم ...تقبل الله اعمال جميع الزملاء والاساتذة الكرم افتح النموذج وقم بلصق بعض الارقام (اجعل بينها فواصل)..اضغط على زر استيراد الارقام..عملت لك بعض الارقام في NotePad قم بنسخها ولصقها في مربع النص ثم افتح الاستعلام codeM.rar
    1 point
  41. التغيير اخي سوف يكون هنا لكن يجب اولا اظافة الشرط الثاني ودالك باظافة كومبوبوكس جديدة وليكن اسمه T2 مثلا من If Rng(i, 4) >= Clé Then الى If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then وافراغ جميع الاكواد السابقة من على اليوزرفورم ونسخ الكود التالي Dim F, rng, Col, width, j, Total() Private Sub UserForm_Initialize() Dim WS As Worksheet: Set WS = Sheets("data") Set d = CreateObject("scripting.dictionary") Set F = WS.Range("A2:E" & WS.[C65000].End(xlUp).Row) rng = F.Value ' الاعمدة الظاهرة على الليست بوكس Col = Array(5, 4, 3, 2, 1) width = Array(100, 100, 100, 100, 100) ' تنسيق عمود المبلغ For i = LBound(rng) To UBound(rng): rng(i, 5) = Format(rng(i, 5), "#,##00.00"): Next i Me.Ls_ATA.ColumnCount = UBound(Col) + 1 Me.Ls_ATA.ColumnWidths = Join(width, ";") Me.Ls_ATA.List = Application.Index(F, Evaluate("Row(1:" & F.Rows.Count & ")"), Col) Total = Col: j = UBound(Total) + 1 ' عمود الفلترة ColTri = 4 For i = LBound(rng) To UBound(rng) d(rng(i, ColTri)) = "" Next i ValTri = d.keys ' ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر P rng, 4, LBound(rng), UBound(rng) ' ترتيب تصاعدي لارقام الفواتير tri ValTri, LBound(ValTri), UBound(ValTri) ' جلب اصغر عدد Me.T1.List = ValTri: Me.T1 = ValTri(0) ' جلب اكبر عدد Me.T2.List = ValTri: Me.T2 = ValTri(UBound(ValTri)) MySum End Sub '***************** Sub Filtre() 'فلترة البيانات Dim Tbl(): n = 0: Clé = Val(Me.T1): Clé2 = Val(Me.T2) For i = 1 To UBound(rng) If rng(i, 4) >= Clé And rng(i, 4) <= Clé2 Then n = n + 1: ReDim Preserve Tbl(1 To j, 1 To n) C = 0 For Each k In Total C = C + 1: Tbl(C, n) = rng(i, k) Next k End If Next i If n > 0 Then Me.Ls_ATA.Column = Tbl MySum Else Me.Ls_ATA.Clear End If End Sub '******combobox (T1 AND T2) 'ترتيب تصاعدي************* Sub tri(a, gauc, droi) ref = a((gauc + droi) \ 2) g = gauc: d = droi Do Do While a(g) < ref: g = g + 1: Loop Do While ref < a(d): d = d - 1: Loop If g <= d Then temp = a(g): a(g) = a(d): a(d) = temp g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call tri(a, g, droi) If gauc < d Then Call tri(a, gauc, d) End Sub '***ترتيب عدد الفواتير على الليست من الاصغر الى الاكبر****** Sub P(a, V, gauc, droi) ref = a((gauc + droi) \ 2, V) g = gauc: d = droi Do Do While a(g, V) < ref: g = g + 1: Loop Do While ref < a(d, V): d = d - 1: Loop If g <= d Then For k = LBound(a, 2) To UBound(a, 2) temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp Next k g = g + 1: d = d - 1 End If Loop While g <= d If g < droi Then Call P(a, V, g, droi) If gauc < d Then Call P(a, V, gauc, d) End Sub '******************************* Sub MySum() Dim Cpt2 As Double, Cpt1 As Double, Cnt As Long Cnt = 0: Cpt = 0: Cpt1 = 0: Cpt2 = 0 With Ls_ATA For r = 0 To .ListCount - 1 Cnt = Cnt + 1 'عدد النتائج Cpt1 = Cpt1 + .List(r, 0) ' مجموع الفواتير Cpt2 = Cpt2 + .List(r, 1) ' اجمالي المبلغ Next r End With LabelCont.Caption = Cnt: SubTotal.Value = Format(Cpt1, "#,##00.00"):: SubTotal2.Value = Cpt2 End Sub '******************************* Private Sub T2_click() If Val(Me.T2) < Val(Me.T1) Then MsgBox "يجب أن يكون الحد الادنى لعدد الفواتير اكبر اويساوي " & Me.T1.Text, vbExclamation, "انتباه" Else Filtre End Sub Private Sub T1_click() If Val(Me.T1) > Val(Me.T2) Then MsgBox "يجب أن يكون الحد الاقصى لعدد الفواتير اصغر او يساوي " & Me.T2.Text, vbExclamation, "انتباه" Else Filtre End Sub اليك الملف للتجربة V3 تجربة (1).xlsm
    1 point
  42. كفكرة جانبية.. لم لا تقوم بإضافة البيانات التي في النموذج الى جدول مؤقت عن طريق استعلام إضافة ، ثم تصدير هذه البيانات الى آكسيل باستعمال إحدى الطرق التي تم ذكرها ، ثم تفريغ الجدول بعد ذلك حتى لا تختلط البيانات ، كونك ترغب بترحيل بيانات محددة معروضة في النموذج الحالي !!!
    1 point
  43. حياك الله أخي سليمان .. - نموذج الصفحة الرئيسية هو منطلقك للدخول إلى باقي أجزاء البرنامج المختلفة .. 🙂 - نعم يمكنك تطويره كما تشاء 🙂✌️
    1 point
×
×
  • اضف...

Important Information