كل الانشطه

وجدت هذا الموضوع ، إن كان يفيدك أيضاً .. وهو تابع لموضوع سابق قمت بالإشارة إليه ..

المرفق لا يصلح على نظام 64 بت كما انه ملئ بالو حدات النمطية الكثيرة وانا اريد وحدة نمطية واحدة فقط وانى استغرب جدا ان المنتدى بهذه الخبرة الكبيرة والحلول لكل شئ ولا يجد حل لهذه المشكلة ام ان الخبراء مشغولين عنا الم يكون هناك وحدة نمطية واحدة تقوم بالمهمة على العموم انا دائما بتعبك معايا وانت خير مثال لمساعدتى دائما طال الله عمرك وجزاك كل خير

السلام عليكم اولا انا عارف ان الموضوع متعب انا بحاول اتعلم من حضراتكم ارجو المساعدة في الشيت الاتي الملف مكون من اكثر من شيت ويريت كتابة الاكواد المستحدمه ولو ممكن شرحها للاستفادة 2010.xlsx

الحل ممكن من خلال الأكواد: و لكن لا تنسى تفعيل اذهب إلى File > Options > Trust Center > Trust Center Settings ثم اذهب إلى Macro Settings فعل الخيار: "Trust access to the VBA project object model" أولا تضع الكود التالي في الملف الذي تريد التصدير منه ' officena.net Sub ExportAllComponentsDynamically() ' --- هذا الكود يقوم بتصدير جميع المكونات ديناميكيًا --- Dim vbComp As Object ' VBComponent Dim exportPath As String Dim componentName As String Dim fileExtension As String ' 1. حدد مسار التصدير exportPath = "C:\ExcelComponents\" ' 2. تأكد من وجود المجلد If Dir(exportPath, vbDirectory) = "" Then MkDir exportPath End If ' 3. ابدأ الحلقة للمرور على كل مكون في المشروع For Each vbComp In ThisWorkbook.VBProject.VBComponents ' تجاهل المكونات الخاصة بالأوراق (Worksheets) و ThisWorkbook If vbComp.Type = 100 Then ' 100 = vbext_ct_Document GoTo NextComponent End If ' 4. حدد امتداد الملف بناءً على نوع المكون Select Case vbComp.Type Case 1 ' vbext_ct_StdModule fileExtension = ".bas" Case 2 ' vbext_ct_ClassModule fileExtension = ".cls" Case 3 ' vbext_ct_MSForm fileExtension = ".frm" Case Else ' تجاهل الأنواع الأخرى GoTo NextComponent End Select ' 5. احصل على اسم المكون componentName = vbComp.Name ' 6. قم بتصدير المكون بالاسم والامتداد الصحيحين Debug.Print "Exporting: " & componentName & fileExtension vbComp.Export exportPath & componentName & fileExtension NextComponent: Next vbComp MsgBox "تم تصدير جميع المكونات بنجاح إلى: " & exportPath End Sub ثانيا تضع الكود التالي في الملف الذي تريد استيراد العناصر إليه ' officena.net Sub ImportAllComponentsDynamically() ' --- هذا الكود يقوم باستيراد جميع المكونات من مجلد محدد --- Dim importPath As String Dim fileName As String ' 1. حدد مسار الاستيراد importPath = "C:\ExcelComponents\" If Dir(importPath, vbDirectory) = "" Then MsgBox "المجلد المحدد غير موجود!", vbCritical Exit Sub End If ' 2. ابدأ بالبحث عن الملفات fileName = Dir(importPath & "*.*") On Error Resume Next ' لتجاهل الأخطاء (مثل محاولة استيراد مكون موجود) ' 3. ابدأ الحلقة للمرور على كل ملف في المجلد Do While fileName <> "" ' 4. تحقق من امتداد الملف قبل الاستيراد If LCase(Right(fileName, 4)) = ".frm" Or _ LCase(Right(fileName, 4)) = ".bas" Or _ LCase(Right(fileName, 4)) = ".cls" Then Debug.Print "Importing: " & fileName Application.VBE.ActiveVBProject.VBComponents.Import importPath & fileName End If ' انتقل إلى الملف التالي fileName = Dir Loop On Error GoTo 0 MsgBox "اكتملت عملية الاستيراد!" End Sub جرب و أبلغنا بالنتيجة اويمكنك استخدام الكود التالي لاستيراد أي عناصر تريدها مباشرة 'Officena.net Sub ImportComponents() ' --- الإصدار الثالث المصحح: استخدام Or بدلاً من In --- Dim sourceWB As Workbook Dim targetWB As Workbook Dim sourceFilePath As Variant Dim tempFolderPath As String Dim vbComp As Object ' VBComponent Dim componentName As String Dim fileExtension As String Dim fileName As String ' --- 1. الإعدادات الأولية --- sourceFilePath = Application.GetOpenFilename( _ FileFilter:="Excel Macro-Enabled Files (*.xlsm), *.xlsm,All Excel Files (*.xls*), *.xls*", _ Title:="الرجاء اختيار ملف Excel المصدر الذي تريد استيراد المكونات منه", _ MultiSelect:=False) If sourceFilePath = False Then MsgBox "تم إلغاء العملية.", vbInformation Exit Sub End If tempFolderPath = Environ("TEMP") & "\VBA_Import_" & Format(Now, "yyyymmdd_hhmmss") & "\" If Dir(tempFolderPath, vbDirectory) = "" Then MkDir tempFolderPath Set targetWB = ThisWorkbook Application.ScreenUpdating = False ' --- 2. فتح المصدر وتصدير المكونات --- On Error GoTo ErrorHandler Set sourceWB = Workbooks.Open(sourceFilePath, ReadOnly:=True, UpdateLinks:=0) sourceWB.Windows(1).Visible = False For Each vbComp In sourceWB.VBProject.VBComponents If vbComp.Type = 100 Then GoTo NextComponent Select Case vbComp.Type Case 1: fileExtension = ".bas" Case 2: fileExtension = ".cls" Case 3: fileExtension = ".frm" Case Else: GoTo NextComponent End Select componentName = vbComp.Name vbComp.Export tempFolderPath & componentName & fileExtension NextComponent: Next vbComp sourceWB.Close SaveChanges:=False Set sourceWB = Nothing ' --- 3. استيراد المكونات إلى الملف الهدف --- fileName = Dir(tempFolderPath & "*.*") Do While fileName <> "" ' === السطر الذي تم تصحيحه === If LCase(Right(fileName, 4)) = ".frm" Or _ LCase(Right(fileName, 4)) = ".bas" Or _ LCase(Right(fileName, 4)) = ".cls" Then On Error Resume Next targetWB.VBProject.VBComponents.Remove targetWB.VBProject.VBComponents(Left(fileName, InStr(fileName, ".") - 1)) On Error GoTo ErrorHandler targetWB.VBProject.VBComponents.Import tempFolderPath & fileName Debug.Print "تم استيراد: " & fileName End If ' ============================ fileName = Dir Loop ' --- 4. التنظيف --- On Error Resume Next Kill tempFolderPath & "*.*" RmDir tempFolderPath On Error GoTo 0 Application.ScreenUpdating = True MsgBox "اكتملت عملية استيراد المكونات بنجاح من الملف: " & vbCrLf & Mid(sourceFilePath, InStrRev(sourceFilePath, "\") + 1), vbInformation Exit Sub ErrorHandler: MsgBox "حدث خطأ:" & vbCrLf & Err.Description, vbCritical, "خطأ" If Not sourceWB Is Nothing Then sourceWB.Close SaveChanges:=False If Dir(tempFolderPath, vbDirectory) <> "" Then On Error Resume Next Kill tempFolderPath & "*.*" RmDir tempFolderPath On Error GoTo 0 End If Application.ScreenUpdating = True End Sub Test.xlsm

الهدف من انشاء سيرقر هو مساعدة الذكاء الصناعي في انشاء قاعدة بيانات وجداول واستعلامات معقدة بشكل سريع هذه محاواتي الاولى يوتيوب

السلام عليكم مشكور أخي الكريم ممكن تعديل إذا أمكن في UserForm خانة التاريخ يكتب تاريخ اليوم تلقائيا أي أقوم بالكتابة في الخانة الأولى فقط. بارك الله فيكم

استكمال 1- اضافة فحص الاتباط 2- فحص وقياس عدد السجلات في الجداول المحلية والشبكة المحلية 3- اضافة 10 جداول مع اضافة بيانات اكثر وهمية الى 1000000 مليون سجل وتقدر تعدل الى 20,000,0000 مليون 4- نافذة الانشاء الجداول والارتباط بحزمة 10 جداول 5- تشغيل وتقسيم والفلترة تم التصحيح 6- اضافة سجلات بتسلسل مع تحديد معيار الحد الاقصى للسجلات لكل جدول مرتبط داخل الكود ============== ناقصة فحص اذا الجدول مرتبط عند التنقل والاضافة بتحديث تحميل المرفق https://www.mediafire.com/file/umnrtj2n6yvijtc/200,000,000_Record_IN_One_Speed_Read_db_Caption_Filter.rar/file يجب اختيار زر انشاء عشر جداول ثم زر الاتصال ثم زر اضافة بيانات وهمية ثم التشغيل😇 للتجرب الى تحديث التالي

وعليكم السلام ورحمة الله تعالى وبركاته جرب إفراغ اليوزرفورم من جميع الأكواد السابقة ولصق الكود التالي ربما يناسبك Option Explicit Public Property Get WS() As Worksheet: Set WS = Sheets("RECAP MDN+DGSN"): End Property Private Sub CommandButton1_Click() Const MAX_DAYS As Long = 90 Dim a As Variant, matricule As String, xDate As Date, lastDate As Date Dim i As Long, tmp As Long, trouve As Boolean, jRestants As Long matricule = Trim(Me.TextBox2.Value) If matricule = "" Then MsgBox "المرجو إدخال رقم التسجيل", vbExclamation, "تنبيه": Exit Sub If Not IsDate(Me.TextBox3.Value) Then MsgBox "المرجو إدخال التاريخ", vbExclamation, "خطأ": Exit Sub xDate = CDate(Me.TextBox3.Value): a = WS.Range("B8:C22").Value For i = UBound(a, 1) To 1 Step -1 If Trim(a(i, 1)) = matricule And IsDate(a(i, 2)) Then lastDate = a(i, 2): trouve = True: Exit For Next i If trouve And xDate - lastDate < MAX_DAYS Then jRestants = MAX_DAYS - (xDate - lastDate) MsgBox "يوجد تسجيل سابق بتاريخ: " & Format(lastDate, "dd/mm/yyyy") & vbCrLf & _ "يرجى الانتظار " & jRestants & " يوم قبل التسجيل مجددا", vbExclamation, "تنبيه" Exit Sub End If For i = 1 To UBound(a, 1) If Trim(a(i, 1)) = "" Then tmp = i: Exit For Next i If tmp = 0 Then MsgBox "النطاق ممتلئ لا يمكن إضافة تسجيل جديد", vbCritical, "خطأ": Exit Sub a(tmp, 1) = matricule: a(tmp, 2) = xDate WS.Range("B8:C22").Value = a MsgBox "تمت إضافة التسجيل بنجاح", vbInformation Me.TextBox2.Value = "": Me.TextBox3.Value = "" End Sub '==================== Private Sub CommandButton4_Click() Dim OnRng As Variant, matricule As String, tmps As Date Dim i As Long, supprimé As Boolean matricule = Trim(Me.TextBox2.Value) If matricule = "" Then MsgBox "المرجو إدخال رقم التسجيل لحذفه", vbExclamation, "تنبيه": Exit Sub If Not IsDate(Me.TextBox3.Value) Then MsgBox "المرجو إدخال التاريخ", vbExclamation, "خطأ": Exit Sub tmps = CDate(Me.TextBox3.Value) If MsgBox("هل أنت متأكد من حذف هذا التسجيل؟" & vbCrLf & _ "رقم التسجيل: " & matricule & vbCrLf & _ "تاريخ التسجيل: " & Format(tmps, "dd/mm/yyyy"), _ vbYesNo + vbQuestion, "تأكيد الحذف") = vbNo Then Exit Sub OnRng = WS.Range("B8:C22").Value supprimé = False For i = 1 To UBound(OnRng, 1) If Trim(OnRng(i, 1)) = matricule And IsDate(OnRng(i, 2)) And CDate(OnRng(i, 2)) = tmps Then OnRng(i, 1) = "": OnRng(i, 2) = "": supprimé = True: Exit For End If Next i If supprimé Then WS.Range("B8:C22").Value = OnRng MsgBox "تم حذف التسجيل بنجاح", vbInformation Else MsgBox "لم يتم العثور على التسجيل المطلوب", vbExclamation, "غير موجود" End If Me.TextBox2.Value = "": Me.TextBox3.Value = "" End Sub Castrole v2.xlsm

طيب اخي جرب هذا المثال وجدته ضمن الملفات المحفوظة عندي علما اني جربته على جهازين : 1024/867 1842/1048 والنتيجة ممتازة جدا انا اتوقع 80% من المشاركات السابقة والامثلة فيها تعمل بشكل صحيح فقط يجب عدم استخدام DoCmd.Maximize لأن المشكلة فيها جميعا من هذا الجانب ضبط النموذج على الشاشة.rar

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

اه حضرتك تقصد كود الوحدة النمطية العامة نعم، لا يمكنك عمل:

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

السلام عليكم

شكرا جزيلا أخي الفاضل وبارك الله فيك

السلام عليكم - العمود b يتم إدخال البانات و c تاريخ إدخالها الشرط هو عند إدخال القيمة المعينة يقوم بالبحث عن آخر تاريخ إدخال لها ويقارنه بتاريخ اليوم فإذا وجدها تجاوزت 90 يوما تضاف القيمة و إلا لا أما بالنسبة ل UserForm فقد أتيت به من ملف آخر وقمت بتعديله وأما الرسالة فلا أعرف لآنني قمت بتعديل وتركت لكم المجال لإصلاحه وتعديله

وعليكم السلام ورحمة الله وبركاته ,, فضلاً منك لا أمراً أخي الفاضل ما يلي :- لم تحدد العمود ؟ الشرط يجب ان يتم مقارنته بقيمة موجودة ، وانت لم تقم بتحديدها ومكانها !! لما يتم النقر على الزر لفتح الـ UserForm ، تظهر الرسالة التالية - - عند الـ ComboBox1 اللي هو المفروض انه في اليوزر فورم ، صحيح ؟ لكنه غير موجود . لإجراءاتكم بتصويب الملف وإعادة ارفاقه مرة أخرى ، مع إضافة بيانات مختلفة التواريخ حتى يستطيع الأخوة والأساتذة والمعلمين تقديم اقتراحاتهم .

ربنا يوفقك ويكرمك

الف الف شكر ذادكم الله من فضله وبارك الله فيك ممتاز الف شكر

السلام عليكم أريد إدخال قيمة في عمود بشرط أن تكون هذه القيمة تجاوزت 90 يوما من آخر إدخال لها فإذا كانت أقل تخرج رسالة تعلم بآخر تاريخ إدخال و كم يوما تبقى وأنه لا يمكن إلا بعد إنقضاء المدة لدي ملف قمت بتعديل فيه و به userform لإدخال البياناتCastrole.xlsm

بوركت جهودك أخونا أبو عيد و جزاكم الله خيرا 💐

جزاك الله كل خير على ما اضحكت به قلبي 😂 لماذا تبحث عن كل هذا التعقيد 🤔 !!؟ أولا الليست بوكس لا يتم إضافة أسماء الصور إلا تلك التي يتم فعلاً إختيارها وإضافتها بنجاح. ثانياً ، لا تستطيع تلوين جزء من قيمة صف في الليست بوكس كما تفكر . ثالثاً ، إذا فكرت في إضافة هذه الجملة ، فسيكون عملك أكبر بحيث أنه عند اختيار أي صورة لعرضها ، فسيعمل الكود على اجتزاء اسم الصورة أولاً ثم عرضها ..... وناهيك عن إحتمالية حدوث الأخطاء. رابعاً ، البساطة في الأفكار جميلة إن كان يمكن تحقيقها بسهولة ، أو حتى لو بالحيلة . لكن في طلبك فإن مارد الفانوس قد استغرب من الطلب 😜 . أرجو أن تكون الفكرة قد توضحت.

اخي الفاضل نسيت اضافة عند كل صورة اريد اظهار * تمت عملية تحميل الصورة بنجاح: هنا اسم الصورة* وتظهر هذه الكلمة امام كل صورة بالون الاخضر با رك الله فيك

وعليكم السلام ورحمة الله وبركاته .. تم إضافة دالة جديدة لإنشاء الجدول المؤقت الجديد "zTempImageReport" ، حيث يتم فيه اضافة سجلات الصور ومساراتها :- Public Function CreateTempImageTable() On Error GoTo ErrorHandler Dim db As DAO.Database Dim tdf As DAO.TableDef Dim fld As DAO.Field Dim tblExists As Boolean Set db = CurrentDb() tblExists = False For Each tdf In db.TableDefs If tdf.Name = "zTempImageReport" Then tblExists = True Exit For End If Next tdf If Not tblExists Then Set tdf = db.CreateTableDef("zTempImageReport") Set fld = tdf.CreateField("ImageName", dbText, 255) tdf.Fields.Append fld Set fld = tdf.CreateField("ImagePath", dbText, 255) tdf.Fields.Append fld Set fld = tdf.CreateField("EmployeeID", dbLong) tdf.Fields.Append fld Set fld = tdf.CreateField("EmployeeName", dbText, 100) tdf.Fields.Append fld db.TableDefs.Append tdf Else db.Execute "DELETE * FROM zTempImageReport", dbFailOnError End If Exit Function ErrorHandler: MsgBox " : حدث خطأ في إعداد الجدول المؤقت" & Err.Description, vbCritical + vbMsgBoxRight, "" Exit Function End Function قمت بإنشاء التقرير "rptImageGallery" ، والذي مصدر سجلاته = الجدول المؤقت السابق "zTempImageReport" ، وفي النموذج في الزر "أمر105" الكود التالي :- Private Sub أمر105_Click() On Error GoTo ErrorHandler If List31.ListCount = 0 Then MsgBox "لا توجد صور ليتم عرضها في التقرير", vbInformation + vbMsgBoxRight, "" Exit Sub End If Call CreateTempImageTable Dim db As DAO.Database Dim rs As Recordset Dim i As Integer Dim ImagePath As String Dim basePath As String basePath = CurrentProject.Path & "\SysFiles\" & Me.ID & "\" Set db = CurrentDb() db.Execute "DELETE * FROM zTempImageReport", dbFailOnError For i = 0 To List31.ListCount - 1 If List31.ItemData(i) <> "" Then ImagePath = basePath & List31.ItemData(i) If Dir(ImagePath) <> "" Then db.Execute "INSERT INTO zTempImageReport " & _ "(ImageName, ImagePath, EmployeeID, EmployeeName) " & _ "VALUES ('" & Replace(List31.ItemData(i), "'", "''") & "', " & _ "'" & Replace(ImagePath, "'", "''") & "', " & _ Me.ID & ", '" & Replace(Me.الاسم, "'", "''") & "')", dbFailOnError End If End If Next i DoCmd.OpenReport "rptImageGallery", acViewPreview Exit Sub ErrorHandler: MsgBox " : حدث خطأ أثناء فتح التقرير" & Err.Description, vbCritical + vbMsgBoxRight, "" End Sub هي فكرة بسيطة تلبي حاجتك ، وتستطيع التعديل عليها حسب حاجتك . الملف بعد التعديل :- الصورة (1).zip

السلام عليكم لدي مجموعة من الصور اريد جمعها في تقرير واحد و اريد عند لا يوجد صور في التقرير لايفتح الصورة (1).rar

هذا يعني انه يجب فصل المكملين في الترم الثاني باستعلام يخصهم والتقرير مبني على جدول الاسماء مع بقية الجداول لذا لزاما تغيير جدول الاسماء باستعلام اسماء المكملين يعني تحتاج تعمل تقرير آخر يخص جداول الدور الثاني مع اني ضد فكرة تكرار الادوات .. الا اني عملت لك ضد منهجي على عجل حاجة يمكن تطلع عليها الى ان يتسنى لي اتفرغ وارى اذا يمكن الدمج جرب على الصف الرابع ... على فكرة : التقرير لا ينظر الى الفصل الدراسي او الفئة .. فقط الصف Data127.rar