كل الانشطه

السلام عليكم لايوجد اي فرق بيننا ابدا نحن فريق واحد ان شاء الله

آها .. التعديل لك عذرا كان المثال محفوظ عندي باسم الأخ صالح 😇 لم اكن متواجدا في النقاش عند طرح الموضوع .. او اني نسيت 😔 المهم في الموضوع هي الفكرة

السلام عليكم انا جربت الكود على الشاشات التالية : 800*600 1024*768 1280*720 1280*768 1360*768 1920* 1080 يعمل بصورة صحيجة عندي بعد ان قمت بتعديل حجم الخط بالنسبة للقوائم المنسدله والحقول لتتلائم مع التكبير والتصغير وهذا كود الاخ @صالح حمادي Option Compare Database Function salah(frm As Form) Dim x, y, x1, y1 As Integer Dim moyH, moyW As Double Dim obj As Control Dim str As String x = frm.InsideHeight 'ارتفاع النموذج قبل التكبير y = frm.InsideWidth ' عرض النموذج قبل التكبير DoCmd.Maximize x1 = frm.InsideHeight 'ارتفاع النموذج بعد التكبير y1 = frm.InsideWidth ' عرض النموذج بعد التكبير moyH = x1 / x 'معامل الإرتفاع moyW = y1 / y ' معامل العرض For Each obj In frm.Controls With obj .Left = .Left * moyW .Top = .Top * moyH .Width = .Width * moyW .Height = .Height * moyH .FontSize = .FontSize * moyW End With Next End Function وهذا الكود بعدل التعدبل علية من حيث جحم الخطوط Option Compare Database Option Explicit Function ResizeForm(frm As Form) On Error GoTo ErrorHandler Dim X As Long, Y As Long, x1 As Long, Y1 As Long Dim moyH As Double, moyW As Double Dim obj As Control Dim maxFontSize As Integer Dim newFontSize As Double maxFontSize = 20 ' الحد الأقصى لحجم الخط ' أبعاد النموذج قبل التكبير X = frm.InsideWidth ' عرض النموذج قبل التكبير Y = frm.InsideHeight ' ارتفاع النموذج قبل التكبير ' تكبير النموذج DoCmd.Maximize ' أبعاد النموذج بعد التكبير x1 = frm.InsideWidth ' عرض النموذج بعد التكبير Y1 = frm.InsideHeight ' ارتفاع النموذج بعد التكبير ' حساب معامل الارتفاع والعرض moyH = Y1 / Y moyW = x1 / X ' تعديل خصائص كل عنصر في النموذج For Each obj In frm.Controls With obj ' ضبط الموضع والحجم .Left = .Left * moyW .Top = .Top * moyH .Width = .Width * moyW .Height = .Height * moyH ' تعديل حجم الخط إذا كان العنصر يدعم ذلك If .ControlType = acTextBox Or .ControlType = acLabel Or .ControlType = acCommandButton Or .ControlType = acComboBox Then If Not IsNull(.FontSize) Then newFontSize = .FontSize * moyH If newFontSize > maxFontSize Then .FontSize = maxFontSize ElseIf newFontSize < 6 Then .FontSize = 6 ' الحد الأدنى لحجم الخط Else .FontSize = newFontSize End If End If End If End With Next obj Exit Function ErrorHandler: MsgBox "حدث خطأ: " & Err.Description, vbCritical End Function وهذا الملف النهائي بعد التعديل تحياتي ملائمة النموذج حسب حجم الشاشة.accdb

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

و عليكم السلام ورحمة الله و بركاته أخي العزيز محمد لقد طلبت عدة أشياء في بوست سابق لها علاقة بهذا الموضوع و قدمنا بعض الحلول و تم تقديم برنامج بسيط يفي بالغرض و لكنك لم تقم بالرد أو تبدي أي ملاحظة على الملف وهذا يسبب احباط لمن أعد و جهز هذا الملف الذي نبتغي به أولا الأجر من الله سبحانه و تعالى ثم مساعدة الأخوة في هذا المنتدى و الذي تخرج منه أساتذة الأكسيل في الوطن العربي. و لذلك فضلا منك قم بالرد على اي مشاركة لسؤالك خاصة إذا كان الحل مرهق و يستغرق وقتا. جزاك الله الخير الكثير الموضوع موجود في الرابط التالي https://www.officena.net/ib/topic/139393-قاعدة-لاجازات-العاملين/#comment-774531

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

المرفق لا يصلح على نظام 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

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