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

تم تحديث الأداة مع إضافة هذا الخيار

جميل جداً .. شكراً لك على هذه المعلومة انا فعلاً وجدت في جوجل الموقع ده ، والرابط للخدمة :- https://www.everythingaccess.com/mdeconversion.asp أما موضوع اثبات الملكية ، يعني لازم أحلف لهم يمين مثلاً هههههههه ولا إيه بالضبط

السلام عليكم تم عمل الاحصائيات الملف المرفق به الاحصاء Plateform3.xlsb الشريط المتحرك ليس لدي جلفية لعملة ولا اراه مهما لانه سيسبب ثقل للملف ا1ذا تحققت طلباتك ارجو فتح موضوع جديد لاي طلب جديد وهذا حسب قوانين المنتدى

الفكرة الجديدة عمل اكثر من نموذج بحث فى قاعدة البيانات نموذج اعدادت بحث للتحكم فى نماذج البحث المختلفة يتم من خلالة عمل ما يلى: تحديد اسم نموذج البحث تحديد مصدر بيانات نموذج البحث سواء كان جدول او استعلان من مربع قيم تحديد حقل او اكثر من حقل لاجراء عملية البحث داخل البيانات لهذا الحقل/الحقول المختارة تطبيق تلوين نتائج البحث ثورة فكرية فى عمل محرك بحث متقدم متعدد الاستخدامات بطرق بحث مختلفة فى النهاية سعدت جدا جدا جدا بالاطلاع على كنز الافكار الموجودة فى المنتدى والقيام بعملية تطويره هذه الافكار فى انتظار ارائكم بالرد بعد التجربة UniversalSearch Pro v2.01.accdb

الفكرو المجنونة فى هذا الموضوع

قم بإزالة علامتي التنصيص حول كلمة red لتصبح بهذا الشكل <font color=red> بدلاً من هذا <font color='red'> تحياتي

اعرض الملف أداة عرض وتحرير جمل Sql داخل التطبيق {سلسلة الأدوات المساعدة المخصصة} اقدم لكم اليوم أداة ستزيد من إنتاجيتكم أثناء العمل مع الإستعلامات فبدلاً من العمل مع الإستعلامات من خلال جزء التنقل ستقوم هذه الأداة بتجميع جميع الإستعلامات داخل مربع قائمة والجميل أنه لن يتم تحميل القائمة إلا بالإستعلامات التي تم تحديد نوعها فمثلاً تريد العمل مع إستعلامات التحديث فقط أو الإلحاق فقط وهكذا بالإضافة إلى هذا يمكنك تصفية النتائج من خلال كتابة عبارة نصية تتضمنها جملة Sql فمثلاً تريد الإستعلامات التي تتضمن بيانات جدول محدد فيكفي أن تكتب إسم الجدول في مربع التصفية ليتم تصفية الإستعلامات التي تتضمن هذا الجدول فقط وكمثال رائع آخر وأعتقد أن جميعنا سيعجب به إذا قمنا مثلا بتعديل إسم عنصر تحكم في نموذج وسبق أن تم وضع عنصر التحكم هذا كمعيار لتصفية إستعلام أو أكثر فيمكن كتابة إسمه في مربع التصفية ليتبقى لدينا الإستعلامات التي ذكر فيها إسم عنصر التحكم هذا لا وأزيدكم من الشعر بيت يمكنكم بعد ذلك إستبدال إسم عنصر التحكم هذا بالإسم الجديد وإستعراض النتائج في إستعلام مؤقت وإذا نجح العمل يمكنك تحديث جملة Sql الخاصة بالإستعلام المحدد بالتعديلات الجديدة وهذا كله عن طريق الأداة وبدون حتى أن تضطر إلى فتح الإستعلام في وضع التصميم يوجد للأداة وظيفة أخرى وهي تعديل جملة Sql الخاصة بعناصر التحكم (مربعات التحرير والسرد ومربعات القائمة) وتقوم بنفس ماسبق ذكره ولكن على عبارة Sql لمصدر الصف الخاص بعنصر التحكم الأداة بسيطة ولا تحتوي إلا على ثلاثة نماذج فقط ستجدونها في المرفق بإسم القالب يمكنكم إستيرادها إلى تطبيقاتكم والعمل بها بكل سهولة ولكن الخيار المفضل لدي هو إستخدامها كوظيفة إضافية وهي ما ستجدونه داخل مجلد الوظيفة الإضافية مع مستند يشرح طريقة تثبيتها أرجو أن تجدوا في هذه الأداة الفائدة التي وجدتها أنا شخصيا وإذا كان لدى أي أحد منكم أي ملاحظات فالرجاء أن لا يبخل علينا بها تحياتي صاحب الملف منتصر الانسي تمت الاضافه 04/01/26 الاقسام قسم الأكسيس  

حل آخر بالكود: Private Sub Worksheet_Change(ByVal Target As Range) Dim Row As Integer, Col As Integer Dim fRow As Integer, fCol As Integer, fdd As Integer Dim yy As Integer, mm As Integer, dd As Integer Dim cellDate As Date, m m = Array("", "يناير", "فبراير", "مارس", "أبريل", "مايو", "يونيو", _ "يوليو", "أغسطس", "سبتمبر", "أكتوبر", "نوفمبر", "ديسمبر") With Target If Not (Target.Row = 1 And Target.Column = 13) Then Exit Sub yy = Year(.Value) mm = Month(.Value) For fdd = 1 To 7 If Weekday(DateSerial(yy, mm, fdd)) = vbSunday Then Exit For Next fdd End With Cells.Find(What:="الأحد", After:=ActiveCell, LookIn:=xlFormulas, _ LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _ MatchCase:=False, SearchFormat:=False).Activate fRow = ActiveCell.Row fCol = ActiveCell.Column + 1 Application.EnableEvents = False Application.ScreenUpdating = False Cells(fRow - 2, fCol + 5) = m(mm) dd = fdd - 3 For Col = fCol To fCol + 9 Step 2 dd = dd + 2 For Row = fRow To fRow + 4 dd = dd + 1 cellDate = DateSerial(yy, mm, dd) If Month(cellDate) = mm Then Cells(Row, Col + 0) = cellDate Cells(Row, Col + 1) = 1 Else Cells(Row, Col + 0) = "" Cells(Row, Col + 1) = "" End If Next Row Next Col Application.EnableEvents = True Application.ScreenUpdating = True End Sub حساب_التاريخ_05.xlsm

تفضل حساب_التاريخ3.xlsx

دعماً لما تفضل به أستاذنا ابو البشر ، المكتبة الموضحة في الصورة التالية :- طبعاً الرقم 16.0 سيختلف حسب إصدار الأوفيس لديك . فللإصدارات التي أقل من 2016 سيكون الرقم 14.0

وعليكم السلام Private Sub cm_ToExcel_Click() On Error GoTo Err_cm_ToExcel_Click Dim stDocName As String Dim Q As Integer Dim sh As Object Dim folder As Object Dim FolderPath As String Dim FilePath As String stDocName = "tbl_Teacher_" & [Year_name] Q = DCount("*", "tbl_Teacher") If Q > 0 Then ' اختيار مجلد Set sh = CreateObject("Shell.Application") Set folder = sh.BrowseForFolder(0, "اختر مجلد حفظ الملف", 0) ' لو إلغاء If folder Is Nothing Then Exit Sub FolderPath = folder.Items().Item().Path FilePath = FolderPath & "\" & stDocName & ".xls" ' 🔥 التحقق من وجود الملف If Dir(FilePath) <> "" Then If MsgBox("الملف موجود بالفعل:" & vbCrLf & FilePath & vbCrLf & vbCrLf & _ "هل تريد استبداله؟", _ vbYesNo + vbQuestion + vbMsgBoxRight, "تأكيد") = vbNo Then Exit Sub End If End If ' التصدير DoCmd.TransferSpreadsheet acExport, 8, "tbl_Teacher", FilePath, False MsgBox "تم حفظ الملف بنجاح في:" & vbCrLf & FilePath, vbInformation + vbMsgBoxRight, "تم" Else MsgBox "لا يوجد سجلات لتصديرها", vbExclamation + vbMsgBoxRight, "تنبيه" End If Exit_cm_ToExcel_Click: Exit Sub Err_cm_ToExcel_Click: MsgBox Err.Description Resume Exit_cm_ToExcel_Click End Sub

السلام عليكم نعم المشكلة من حماية الشيتات اليك التعديل مع اظافة الترقيم التلقائي لرقم التسجيل Plateform (1) .xlsb

نعم الموقع ثقة ، وانا اشرت الى هذا في الرابط التالي ، وهناك رد من الاخ @محمد سلامة عن طريقة لا اعرفها:

وعليكم السلام ورحمة الله 🙂 باستخدام هذه الأداة : Private Sub cmdPrint_Click() On Error GoTo Err_cmdPrint_Click Dim Index3 As Variant Dim repName As String Dim ftrName As String ' Declare ftrName, assuming it's a String for the filter argument. ' Check if any items are selected from the listbox. If L3.ItemsSelected.Count = 0 Then MsgBox "لا يوجد مطبوغات قد تم اختيارها", vbInformation + vbMsgBoxRight, "تنبيه " Exit Sub End If ' Loop through each selected item and open the corresponding report. For Each Index3 In L3.ItemsSelected repName = L3.ItemData(Index3) repName = "تقرير_" & repName DoCmd.OpenReport repName, acViewNormal, , ftrName Next Index3 Exit_cmdPrint_Click: Exit Sub Err_cmdPrint_Click: MsgBox Err.Description Resume Exit_cmdPrint_Click End Sub مع اختيار : والتعليمات نفس رسالتك مع تغيير بسيط : الكود التالى يعمل بدون مشاكل ولكن هناك سطور مكررة متداخلة به يرجى ضبط بناء الكود لاختصاره وتحسينه

بحث متعدد امكانية اختيار حقل او حقول بحث من خلال كود مركزى فى وحدة نمطية لتطبيق فكرة البحث فى اكثر من نموذج أقدم لكم وحدة نمطية عامة جاهزة للاستخدام تحول اى نموذج إلى محرك بحث تفاعلى بمميزات احترافية تدعم: البحث فوري أثناء الكتابة (Search As You Type) تلوين HTML للكلمات المطابقة للنتائج بلون أحمر <font color=red> بحث متعدد الحقول بحث متعدد الكلمات دعم كامل للحالات المتقدمة "ط" ← تلوين "ط" في كل الحقول "ط ر ة" ← تلوين "ط" + "ر" + "ة" مع فلتر AND "ط " ← مسافة محفوظة (تلوين فقط) Backspace/Delete ← فلتر يتجدد النقر المزدوج - Double Click ← مسح فورى بحث بدون نتائج ← رسالة + إلغاء فى حالة عدم وجود نتائج الوحدة النمطية العامة مثلا باسم : modMultipleSearchHighlights Option Compare Database Option Explicit Private Const CTRL_PREFIX As String = "txt" Public Sub InitUniversalSearch(frm As Form, fieldNames As String) On Error GoTo ErrHandler Dim arr() As String: arr = Split(fieldNames, ",") Dim i As Integer, fld As String For i = 0 To UBound(arr) fld = Trim(arr(i)) frm.Controls(CTRL_PREFIX & fld).ControlSource = "=[" & fld & "]" Next i Exit Sub ErrHandler: MsgBox "خطأ في InitUniversalSearch: " & Err.Number & " - " & Err.Description & vbCrLf & "الحقل: " & CTRL_PREFIX & fld, vbCritical, "خطأ في البحث" End Sub Public Sub UpdateSearch(txtBox As TextBox, frm As Form, fieldNames As String) On Error GoTo ErrHandler Dim searchValue As String Dim currentPos As Long searchValue = txtBox.text currentPos = Len(searchValue) If Len(searchValue) = 0 Then ResetAllHighlights frm, fieldNames frm.FilterOn = False ElseIf Right(searchValue, 1) = " " Then ApplyHighlightsOnly frm, fieldNames, searchValue Else ApplyHighlightsOnly frm, fieldNames, searchValue frm.Filter = BuildFilterSQL(fieldNames, searchValue) frm.FilterOn = True If frm.Recordset.RecordCount = 0 Then MsgBox "لا توجد نتائج لـ """ & searchValue & """" & vbCrLf & "عدد السجلات: 0", vbInformation, "نتائج البحث" frm.FilterOn = False End If End If Dim wasFocused As Boolean: wasFocused = (Screen.ActiveControl.name = txtBox.name) txtBox.SetFocus txtBox.SelStart = currentPos txtBox.SelLength = 0 If Not wasFocused Then Screen.PreviousControl.SetFocus Exit Sub ErrHandler: Select Case Err.Number Case 2185 Debug.Print "UpdateSearch 2185 ignored: " & Err.Description Resume Next Case 2474, 6139 Debug.Print "UpdateSearch ignored: " & Err.Number & " - " & Err.Description Resume Next Case Else Debug.Print "UpdateSearch Error: " & Err.Number & " - " & Err.Description MsgBox "خطأ في البحث: " & Err.Number & vbCrLf & Err.Description, vbCritical Resume ExitHandler End Select Resume Next ExitHandler: End Sub Private Function ReplaceMultiple(inputText As String) As String Dim result As String: result = inputText result = Replace(result, "'", "''") result = Replace(result, "[", "[[]") result = Replace(result, "?", "[?]") result = Replace(result, "*", "[*]") result = Replace(result, """", """""") ReplaceMultiple = result End Function Private Sub ApplyHighlightsOnly(frm As Form, fieldNames As String, searchText As String) Dim arr() As String: arr = Split(fieldNames, ",") Dim words() As String: words = Split(searchText, " ") Dim i As Integer, w As Integer, fld As String Dim ctrl As Control, expr As String, safeWord As String On Error GoTo ErrHandler Application.Echo False For i = 0 To UBound(arr) fld = Trim(arr(i)) Set ctrl = frm.Controls(CTRL_PREFIX & fld) On Error Resume Next Do While ctrl.FormatConditions.Count > 0 ctrl.FormatConditions(1).Delete Loop On Error GoTo ErrHandler expr = "Nz([" & fld & "], """")" For w = 0 To UBound(words) If Len(Trim(words(w))) > 0 Then safeWord = ReplaceMultiple(Trim(words(w))) expr = "Replace(" & expr & ",""" & safeWord & """,""<font color=red>" & safeWord & "</font>"")" End If Next w ctrl.ControlSource = "=IIf(Len(" & expr & ")>0, " & expr & ", """")" Next i Application.Echo True Exit Sub ErrHandler: Application.Echo True Debug.Print "ApplyHighlightsOnly Error: " & Err.Number & " - " & Err.Description & " (Field: " & fld & ")" End Sub Private Sub ResetAllHighlights(frm As Form, fieldNames As String) Dim arr() As String: arr = Split(fieldNames, ",") Dim i As Integer, fld As String, ctrl As Control On Error GoTo ErrHandler Application.Echo False For i = 0 To UBound(arr) fld = Trim(arr(i)) Set ctrl = frm.Controls(CTRL_PREFIX & fld) On Error Resume Next Do While ctrl.FormatConditions.Count > 0 ctrl.FormatConditions(1).Delete Loop On Error GoTo ErrHandler ctrl.ControlSource = "=[" & fld & "]" Next i Application.Echo True Exit Sub ErrHandler: Application.Echo True Debug.Print "ResetAllHighlights Error: " & Err.Number & " - " & Err.Description End End Sub Private Function BuildFilterSQL(fieldNames As String, searchText As String) As String On Error GoTo ErrHandler Dim arrFields() As String: arrFields = Split(fieldNames, ",") Dim words() As String: words = Split(searchText, " ") Dim conditions As String, i As Integer, w As Integer Dim wordCond As String, safeWord As String For w = 0 To UBound(words) If Len(Trim(words(w))) > 0 Then safeWord = ReplaceMultiple(Trim(words(w))) wordCond = "" For i = 0 To UBound(arrFields) If i > 0 Then wordCond = wordCond & " OR " wordCond = wordCond & "[" & Trim(arrFields(i)) & "] Like '*" & safeWord & "*'" Next i If Len(conditions) > 0 Then conditions = conditions & " AND " conditions = conditions & "(" & wordCond & ")" End If Next w BuildFilterSQL = IIf(Len(conditions) = 0, "", conditions) Exit Function ErrHandler: BuildFilterSQL = "" Debug.Print "BuildFilterSQL Error: " & Err.Number & " - " & Err.Description End Function إعدادات النموذج المطلوبة مربع نص البحث باسم : txtSearch مربعات نص الحقول المطلوب البحث بداخلها : يجب ان تكون غير منضمة : Unbound يجب ان تكون Rich Text يجب ان تكون بنفس اسم الحقل تماما وتسبقها البادئة : txt فمثلا فى المرفق الحقول المطلوب البحث بداخلها كانت باسم :item_na, class_no اذن اسماء مربعات النص فى النموذج لتلك الحقول سوف تكون بالاسماء: txtitem_na, txtclass_no مصدر بيانات النموذج (Record Source) :اسم الجدول او استعلام للجدول عادى Query/Table الاكواد المطلوبة فى النموذج ثابت لادراج اسماء الحقول المراد البحث بداخلها مثل Private Const strUniversalfieldNames As String = "item_na,class_no" وفى حدث تحميل النموذج Private Sub Form_Load() InitUniversalSearch Me, strUniversalfieldNames End Sub أحداث مربع النص الخاص بالبحث : txtSearch يمكن استخدام حدث عند التغيير (Change) أو حدث بعد التحديث (AfterUpdate) ولكن الافضل فى السرعة والاداء خاصة مع كثرة عدد السجلات او عند استخدام التطبيق فى شبكة محلية لضمان الكفائة فى الاداء والسرعة يفضل استخدام الكود التالى فى حدث بعد التحديث (AfterUpdate) UpdateSearch Me.txtSearch, Me, strUniversalfieldNames ولكن انا فقط فى المرفق استخدمت حدث عند التغيير لرؤية النتيجة فورية فقط وبعد ذلك يمكن عمل زر امر لعمل مسح للفلاتر ولمربع النص او كود فى حدث النقر المزدوج لمربع البحث : txtSearch Me.txtSearch.Value = "" UpdateSearch Me.txtSearch, Me, strUniversalfieldNames واخيرا المرفق Search Highlights.accdb

اهلا استاذ سعيد جدا بمرورك واسعدتنى كلماتك واكثر ما اسعدنى هو اعجابك بهذا الجنون

راااائع والله تطبيق عبقري لفكرة مجنونة كما أسميتها

أنا جربت التعديل الأخير UniversalSearch Pro v2.01 وهو رائع حقاً. . وأقترح في نموذج الاعدادات: frmSearchSettings وجود إمكانية لظهور حقول الجدول مصدر البيانات بتسميات اخرى على اعتبار أن المستخدم ربما لا يعلم مدلول اسماء الحقول. أو ظهورها كما تم تسميتها في خصائص الحقل: Caption فمثلا تظهر : كود الصنف اسم الصنف مجموعة الصنف رصيد الصنف بدلا من : item_id item_na class_no item_balance .

اعرض الملف أداة إنشاء لوحة رئيسية مخصصة {سلسلة الأدوات المساعدة المخصصة} قد يكون من أهم إستخدامات كائن الشجرة Treeview هو إستخدامها في شجرة الحسابات أو الهياكل التنظيمية ولكن يوحد لهذا الكائن وظيفة هامة أخرى وهي إستخدامه في شاشة لوحة التبديل أو شاشة التنقل الرئيسية Switchboard لذا وبإستخدام الأداة المرفوعة سابقاً في هذا الموضوع يمكننا الحصول على أكثر من شكل لشاشة لوحة التبديل الرئيسية . يتم من خلال الأمثلة المرفقة وعند النقر على عناصر الشجرة القيام بأحدى الوظائف التالية - فتح نموذج بشكل طبيعي (أو كنموذج فرعي عند إستخدام لوحة التبديل الجانبية) مع إمكانية إضافة معلمات لحاصية OpenArgs - فتح نموذج بشكل منبثق أو مشروط مع إمكانية إضافة معلمات لحاصية OpenArgs - فتح تقرير في وضع المعاينة مع إمكانية إضافة معلمات لحاصية OpenArgs - طباعة تقرير مباشرة مع إمكانية إضافة معلمات لحاصية OpenArgs - تشغيل إجراء عام (يجب أن يكون إجراء في وحدة نمطية ويجب أن يكون بدون معلمات) - إستدعاء دالة عامة (يجب أن تكون إجراء في وحدة نمطية مع أو بدون معلمات) ستجدون في المرفقات الملفات التالية : 1 - النموذج الأول لشاشة التبديل + القالب الخاص به في هذا المثال سنحصل على لوحة تبديل مستقلة يمكن إستخدامها كشاشة رئيسية للتطبيقات الخاصة 2 - النموذج الثاني لشاشة التبديل + القالب الخاص به في هذا المثال سنحصل على لوحة تبديل جانبية تقوم بفتح النماذج كنماذج فرعية ضمن الشاشة الرئيسية 3 - النموذج الثالث لشاشة التبديل + القالب الخاص به وهو نسخة مطابقة للنموذج الثاني ولكنها مخصصة لمن يستخدمون اللغة الإنجليزية في الواجهات الخاصة بهم لاتوجد أي تعليمات إضافية فآلية العمل هي نفسها الموضحة في الموضوع الخاص بإداة Treeview المخصصة ولكن سنجد هنا بعض الإضافات على النحو التالي - إظهار أيقونة تميز عناصر المستوى الأول عن بقية المستويات - تبديل أيقونتي الجمع والطرح بأشكال أخرى (لمن يحبون التغيير) - طريقة تحويل إتجاه الشجرة من اليسار إلى اليمين لمن يستخدمون اللغة الإنجليزية في تطبيقاتهم وهذا يعني أنه يمكننا القيام بنفس التعديلات على الأداة في الموضوع السابق للحصول على نفس النتائج هنا من المزايا الإضافية المقدمة مع الإداة أنه عند إستخدام النموذج الثاني أو الثالث سنجد كيف نقوم بإظهار شاشة عامة تحتوي على أيقونة وعنوان التطبيق وأي معلومات إضافية نرغب في إظهارها وتظهر هذه الشاشة عندما لايتم تحديد أي عنصر من القائمة أو أن تحديد العنصر لاينتج عنه فتح أي نموذج فرعي تحياتي صاحب الملف منتصر الانسي تمت الاضافه 03/04/26 الاقسام قسم الأكسيس  

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

* وظيفة LIKE تستخدم لمقارنة النصوص مع نمط (Pattern) معيّن. النمط يحتوي على رموز خاصة (Wildcards) تسمح بالبحث الجزئي أو المرن داخل النصوص. * أمثلة عملية في VBA Dim txt As String txt = "Mahdi" ' مثال 1: البحث عن نص يبدأ بـ "M" If txt Like "M*" Then MsgBox "يبدأ بحرف M" End If ' مثال 2: نص مكون من 5 أحرف بالضبط If txt Like "?????" Then MsgBox "النص يحتوي على 5 أحرف" End If ' مثال 3: نص ينتهي بـ "di" If txt Like "*di" Then MsgBox "ينتهي بـ di" End If ' مثال 4: نص يحتوي على رقمين متتاليين Dim code As String code = "AB12" If code Like "*##" Then MsgBox "ينتهي برقمين" End If

تم تعديل مثالك ليتم إظهار الجداول في القائمة وحذف بيانات الجدول المحدد وإعادة الترقيم من 1 نسخ قاعدة البيانات قبل الحدف.accdb

أعجز عن وصف شعوري بهذا الكلام من أستاذ كبير مثلك 🥰

وعليكم السلام ورحمة الله وبركاته اليك التعديل المطلوب Horaire1.xlsb

غفر الله ذنوبك كلها وعفا عنك وأحسن إليك ورزقك من حيث لا تحتسب .. لك ولوالديك وجميع أحبابك 😊🤲 وعدت فأوفيت .. وصنعت تحفة راااااائعة قمة في الجمال .

وتنفيذاً للوعد الذي وعدته للأخ @Moosak قمت بإضافة أداة مساعدة في إنشاء صيغ أوامر مربع الرسائل MsgBox إلى مكتبة الموقع

بارك الله فيك وزدك الله من فضله .. وجعل الله هذا العمل فى ميزان حسناتك ان شاء الله وبالتوفيق والنجاح دائماَ

لكم مني كل الاحترام والتقدير 👍

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

تمام أخى الفاضل Foksh شكراً لك .. هذا ما أريده تماماً وتم التعديل بسهولة لدمج 3 كائنات فى زر أمر واحد ( زر استيراد الجدول ) للتجربة تكون بمراعاة الأرقام الظاهرة على الصورة Test1.mdb

اعرض الملف أداة إنشاء صيغة أوامر مربع الرسائل MsgBox القياسي {سلسلة الأدوات المساعدة المخصصة} أقدم لكم اليوم أداة بسيطة ولكن فائدتها كبيرة لما تختصره من الوقت والجهد في كتابة الأوامر الخاصة بمربعات حوار الرسائل MsgBox خصوصاً في حالة النصوص الطويلة بإستخدام هذه الأداة لن تحتاج إلا إلى إدخال عنوان الرسالة والنص الخاص بها وتحديد بقية الخيارات من خلال تحديدها من قائمة الخيارات بدون الحاجة إلى أي معرفة برمجية وعند الإنتهاء من تحديد الخيارات يمكنك إستعراض الرسالة للتأكد من ظهورها بالشكل المطلوب وعندها كل ماعليك هو نقر زر لنسخ صيغة الأمر والذهاب للمكان المطلوب في تطبيقك ولصقه بإمكان الأداة القيام بإنشاء صيغتين للأمر 1- صيغة الأمر البسيطة والتي ستكون بالشكل التالي MsgBox "نص الرسالة",vbOk,"العنوان" 2- صيغة الأمر ضمن شرط If وستظهر عندما تحتوي الرسالة على أكثر من زر لتصبح بالشكل التالي If MsgBox ("نص الرسالة",vbOkCancel,"العنوان")=vbOk Then End If كذلك ستجد خيارات إضافية كإمكانية تحديد إتجاه الرسالة لتناسب الرسائل باللغة العربية أو الإنجليزية وإمكانية الإحتفاظ بالنص في متغير والذي يكون مفيداً للغاية عند العمل مع النصوص الطويلة والتي تحتوي على أكثر من سطر وغيرها من المزايا الإضافية التي ستجدونها من خلال تجربتكم للأداة. كما ذكرت فالأداة بسيطة جداً لدرجة أني لم أحتاج لإضافة أي تعليمات توضيحية لطريقة عملها فهي لاتحتوي إلا على نموذج واحد فقط ويمكنك تخصيص قاعدة بيانات مستقلة للقيام بمساعدتك في إنشاء الصيغ لبقية التطبيقات أو إستيراد النموذج لأي تطبيق والعمل به بكل بساطة. كفائدة إضافية وحتى لا تحتاج لإستيراد النموذج إلى جميع تطبيقاتك فقد أنشأت منه نسخة تعمل كوظيفة إضافية Add-In مرفق معها مستند وورد يشرح طريقة تثبيتها وإستخدامها أرجو أن تنال هذا الأداة إعجابكم وإذا كانت هناك أي ملاحظات فأرجو ذكرها تحياتي صاحب الملف منتصر الانسي تمت الاضافه 03/26/26 الاقسام قسم الأكسيس  

الخبير المبدع الذى اتابع كل اعمالة واتعلم منها خالص الشكر لسرعة الاستجابة وإضافة Select Case للبرنامج شكرررررررررا

الخبير الفاضل شكرا لابداعك المتجددة لي طلب بسيط ممكن لو تكرمت تستبدل قاعدة If بقاعدة Select Case حتى نتمكن من عمل امر لكل زر فى الرسالة مثلا لو حددنا ٣ ازرار نعم ولا وإلغاء الامر نعم فتح نموذج محدد لا لفتح تقرير محدد الغاء الأمر لغلق الرسالة لانى قمت بتجربة هذا الموضوع نعم يفتح النموذج تمام لا يفتح التقرير تمام الغاء الأمر حاولت بكل الطرق Undo Exit Sub لكنة يكرر الأمر السابق وهو فتح التقرير لذلك ارجوك تحويل قاعدة If إل cselect case لك خالص الشكر

شكراً أخى Moosak على مشاركتك بنقل ما تفضلت به للمشروع لم يتغير شئ الكود الوحيد الذى يعمل بلا مشاكل هو كود أخى ابو البشر وإن كان فى حاجة لبعض الإضافات لكنه هو الصحيح بلا أى مشكلة عندى

هذه هي المكتبة المطلوبة

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

كلام صحيح 100%

طالما وهذا الحل يناسبك خلاص مافي مشكلة بس تعمل حسابك إن الرابط هيضل ثابت ماراح يتغير لو حصل أي تغيير في موقع الهدف

Foksh اخوي جزاك الله خير الحمد الله انحلت وهي عن طريق الماوس واختار الرابط

الشرح غير موجود

تفضل استاذ @dd13901390 طالع الشرح جيداً واليك المرفق . ووافني بالرد . DD13901390.rar

اكيد هتعرف لما تتواصل معهم الالية

https://learn.microsoft.com/en-us/answers/questions/4884176/get-to-vba-code-in-access-split-database خدمة EverythingAccess.com: حسب البحث اعتقد انهم متخصصون في تحويل ACCDE إلى ACCDB كامل مع VBA ولكن سوف يطلبون إثبات الملكية

كان الله في عونك اخي الكريم لا اعتقد هناك برامج 😭 ولكن انظر هذا الموقع ولم اجربهم شخصيا .... ولكن احذر من النصب وتأكد من مصداقيتهم في استرجاع الاكواد ... فرج الله همك EverythingAccess.com

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

وعليكم السلام ورحمة الله وبركاته كل عام وانت بخير الصفحات كثيرة وهذا سيجعل اي كود يستغرق وقتا اطول لاستدعاء البيانات استغرق على جهازي حوالي 6 دقائق بمعدل ثانية واحدة لكل صفحة فكرة الاكواد ؟ الكود الاول (اسعار الاسهم ) يتم تشغيله مرة واحدة فقط ويستغرق عدة دقائق بعدها يتم التعامل مع زر التحديت ويستغرق اقل من دقيقة واحدة من خلال 3 مواقع ذكاء اصطناعي تحصلت على افضل كود يقوم بالمهمة التجرية تمت على اكسل 2016 لانه ليس لدي 2010 واعتقد ان الكود يعمل علي 2010 زر التحديث / بعد استدعاء البيانات يقوم زر التحديث بمقارنة البيانات المستدعاة بالموقع واذا كان هناك تغير يقوم يالتحديث قم بالتجربة واعلمنا بالنتائج افضل الاكواد تحصلت عليها من موقع https://chat.deepseek.com/ us_stocks_arincen (1).xlsb

وعليكم السلام -لا يمكنك هذا الا من خلال هذا الموقع الطباعة بدون فتح ملف (طباعة مباشرة)

أخى أبو زهرة جرب هذا الكود Sub ChangingPaperSize() Application.ScreenUpdating = False Dim Cl As Range blnAns = Application.InputBox("أدخل 3 للطباعة على ورق 3" & vbCr & "أدخل 4 للطباعة على ورق 4", "اختر نوع ورق الطباعة", , , , , , 4) If blnAns = 3 Then For Each Cl In Range("e11:e35") If Cl.Value = "" Or Cl.Value = 0 Then Cl.EntireRow.Hidden = True End If With ActiveSheet.PageSetup .Zoom = False .FitToPagesWide = 2 .FitToPagesTall = 1 .PaperSize = xlPaperA3 On Error Resume Next End With Next Cl ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False Else For Each Cl In Range("e11:e35") If Cl.Value = "" Or Cl.Value = 0 Then Cl.EntireRow.Hidden = True End If With ActiveSheet.PageSetup .Zoom = False .FitToPagesWide = 2 .FitToPagesTall = 1 .PaperSize = xlPaperA4 On Error Resume Next End With Next Cl ActiveWindow.SelectedSheets.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False End If Rows("11:36").Select Selection.EntireRow.Hidden = False Range("A1").Select Application.ScreenUpdating = True End Sub