Moosak

الأفضل أن تكتبها هكذا أخي العزيز .. ERR: If ERR.Number = 3078 Then MsgBox "الجدول المصدر ( " & Me.txt1 & " ) غير موجود !!", vbInformation + vbOKOnly + vbMsgBoxRight + vbMsgBoxRtlReading, "خـطـأ" DoCmd.RunSQL "DROP table [" & Me.txt2 & "]" Exit Sub ElseIf ERR.Number = 0 Then Exit Sub Else MsgBox ERR.Number & vbCrLf & ERR.Description, vbInformation End If السطر الذي ذكره أخي العزيز @Barna مهم جدا ومفيد لتعقب الأخطاء .. وهو الذي أعطاك أن رقم الخطأ = 0 .. ويشير رمز الخطأ 0 إلى عدم وجود حالة خطأ... لذلك نضع له حالة خاصة به بأن يتم تجاهل الرسالة .

تم ضبط الدالة ولله الحمد : Public Function MidText(strText As String) As String Dim x As Integer Dim t As String Dim s As Integer Dim L As Integer If IsNull(strText) Or strText = "" Then MidText = "": Exit Function s = InStr(1, strText, "عن") For x = 1 To Len(strText) t = Mid(strText, x, 1) If t = ChrW(10) And x > s Then L = x Exit For End If Next If L = 0 Then L = Len(strText) ' Debug.Print s, L MidText = Mid(strText, s, L - s + 1) End Function Short text.rar

سأعالجه لك لاحقا بإذن الله

الموضوع صار بسيط الآن أخي @nssj 🙂 يمكن تطبيق فكرتك في الدالة الرئيسية .. Public Function MidText(strText As String) As String Dim Txt as String Dim x As Integer Dim t As String Dim s As Integer Dim L As Integer Txt = "@@@" & strText s = InStr(1, Txt, "عن") For x = 1 To Len(Txt) t = Mid(Txt, x, 1) If t = ChrW(10) And x > s Then L = x Exit For End If Next 'Debug.Print s, L MidText = Mid(Txt, s, L - s + 1) End Function جرب وقلي .. لأني أكتب من الهاتف ..

أهلا أخي @nssj الكود السابق لم يعمل بسبب أن الرمز chr(10) ورد أكثر من مرة في النص .. وهو يحضر أول ورود له .. وأول ورود له يقع قبل كلمة "عن" لهذا السبب لم تعمل دالة mid.. لذلك قمت بعمل دالة تبحث عن ال chr(10) التي تقع بعد "عن" .. هذه هي الدالة ضعها في محرر الأكواد : Public Function MidText(strText As String) As String Dim x As Integer Dim t As String Dim s As Integer Dim L As Integer s = InStr(1, strText, "عن") For x = 1 To Len(strText) t = Mid(strText, x, 1) If t = ChrW(10) And x > s Then L = x Exit For End If Next 'Debug.Print s, L MidText = Mid(strText, s, L - s + 1) End Function ثم استدعها في مربع نص النتيجة هكذا : =MidText([Text1]) حيث ان [Text1] هو اسم خلية المصدر

أعذرني أخي @nssj .. بعيد عن الجهاز هذي الأيام .. سأحاول إيجاد فرصة للإصلاح

أساسا تصميم البرنامج بسيط جدا فقط جداول وواجهة وبعض الموديولات البسيطة ..

لا يوجد بها جداول مخفية غير جداول النظام

هل حملته من مكتبة الموقع أخي @Barna ؟ أم من رابط خارجي ؟ هل حاولت تنزله بطرق أخرى ؟ حجب برنامج الفيروسات مثلا ؟ مستغرب أن كم شخص اشتكوا من حجب برامج الفيروسات له ؟ ما السبب ياترى ؟

شكرا أخي عمر 🌹 الحمدلله

سؤال يا إخوان : 🙂 هل واجه أحد منكم أية مشاكل عند تحميل الملف ؟ أو ظهر له بأنه فيروس ؟

تفضل أخي العزيز هذه هي الدالة 🙂 =Mid([Text1];InStr(1;[Text1];"عن");InStr(1;[Text1];".")-InStr(1;[Text1];"عن")+1) تضعها في مصدر مربع النص الذي سيظهر النتيجة .. و Text1 هو مربع النص المصدر .. أعتذر لعدم التطبيق في ملفك .. ليس لدي إنترنت في الجهاز. اختصار الوقت.accdb

اللهمّ آمين يارب العالمين🌹 شكرا لكم جميعا 🌹😊

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

اللهم آمين أخي حسين

غريب .. أنا يفتح لدي بشكل طبيعي .. مع جعل خاصية التوسيط التلقائي = نعم

أخي @RaDwAn00 ضع عند حدث فتح التقرير هذا الأمر : DoCmd.Restore بدل ال DoCmd.Maximize

مشاركة مع أخي عمر 🙂 Status: IIf(Date()>=[nometprn] And Date()<=[DAu];"((مازال قيد الاجازة))";IIf(Date()>[DAu];"(( تم العودة من الاجازة))";"((الإجازة لم تبدأ بعد))")) 174971286_11.accdb

تفضل هذا طلبك أخي @naguib_3778 🙂 Private Sub Command1_Click() Dim s As String s = InputBox("أدخل الرقم السري", "", "123") If s = 123 Then '--------------------------------(إخفاء الريبون والنفجيشن بان) DoCmd.ShowToolbar "Ribbon", acToolbarNo ' Hide Navigation Pane: DoCmd.NavigateTo ("acnavigationcategoryobjecttype") DoCmd.RunCommand (acCmdWindowHide) End If End Sub Private Sub Command0_Click() Dim s As String s = InputBox("أدخل الرقم السري", "", "123") If s = 123 Then '--------------------------------(إضهار الريبون والنفجيشن بان) DoCmd.ShowToolbar "Ribbon", acToolbarYes Call DoCmd.SelectObject(acTable, , True) 'Unhide the navigation pane End If End Sub Hide Navigation Pane.accdb

جرب نقل التركيز للنموذج الفرعي أولا

أنا جربته على زر في نموذج منقسم ونجح الأمر ( طبعا تشغيل / وإطفاء ) بنفس الكود .. وحسب المصدر هذه طريقة فتح استعلام وتشغيل المجاميع بنفس الأمر DoCmd.OpenQuery CustName, acViewNormal CommandBars.ExecuteMso "RecordsTotals" أو ضع أنت مرفق مبسط حسب تصميم برنامجك لنجرب الأمر عليه 🙂

وعليك السلام ورحمة الله وبركاته أخي عبدالله .. 🙂 استخدم هذا الأمر : Application.CommandBars.ExecuteMso "RecordsTotals"

مع البحث وجدت هذا الموضوع فيه كود لعله يساعدك : https://stackoverflow.com/questions/37426141/access-vba-connection-to-test-existence-of-sql-server وهذا هو الكود : Public Function IsSqlServer( _ ByVal TestNewConnection As Boolean, _ Optional ByVal Hostname As String, _ Optional ByVal Database As String, _ Optional ByVal Username As String, _ Optional ByVal Password As String, _ Optional ByRef ErrNumber As Long) _ As Boolean Const cstrQuery As String = "VerifyConnection" Dim dbs As DAO.Database Dim qdp As DAO.QueryDef Dim rst As DAO.Recordset Dim booConnected As Boolean Dim strConnect As String Dim strConnectOld As String Dim booCheck As Boolean Set dbs = CurrentDb Set qdp = dbs.QueryDefs(cstrQuery) If Hostname & Database & Username & Password = "" Then If TestNewConnection = False Then ' Verify current connection. booCheck = True Else ' Fail. No check needed. ' A new connection cannot be checked with empty parameters. End If Else strConnectOld = qdp.Connect strConnect = ConnectionString(Hostname, Database, Username, Password) If strConnect <> strConnectOld Then If TestNewConnection = False Then ' Fail. No check needed. ' Tables are currently connected to another database. Else ' Check a new connection. qdp.Connect = strConnect booCheck = True End If Else ' Check the current connection. strConnectOld = "" booCheck = True End If End If On Error GoTo Err_IsSqlServer ' Perform check of a new connection or verify the current connection. If booCheck = True Then Set rst = qdp.OpenRecordset() ' Tried to connect ... If ErrNumber = 0 Then If Not (rst.EOF Or rst.BOF) Then ' Success. booConnected = True End If rst.Close End If If strConnectOld <> "" Then ' Restore old connection parameters. qdp.Connect = strConnectOld End If End If Set rst = Nothing Set qdp = Nothing Set dbs = Nothing IsSqlServer = booConnected Exit_IsSqlServer: Exit Function Err_IsSqlServer: ' Return error. ErrNumber = Err.Number ErrorMox "Tilslutning af database" ' Resume to be able to restore qdp.Connect to strConnectOld. Resume Next End Function

وعليكم السلام أخي أزهر 🙂 عملت لك الكود التالي في حدث عند عدم وجود في القائمة للقائمة المنسدلة : Private Sub numb_NotInList(NewData As String, Response As Integer) CurrentDb.Execute " INSERT INTO tbb ( numb, nameb ) VALUES ( '" & NewData & "' , '" & NewData & "' );" numb = Null numb.Requery numb = NewData End Sub bl.accdb

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