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

طيب أهلا عمر .... جرب هل هذا ما تريد ؟؟ On Error GoTo Errw Dim i As Integer DoCmd.GoToRecord , , acFirst For i = 1 To Me.Recordset.RecordCount If Me.Emp_ABSCENT = False Then txtTimeIn.Value = Time Else txtTimeIn.Value = "" End If DoCmd.GoToRecord , , acNext Next i Exit Sub Errw: MsgBox "لقد تم اعتماد الحضور بنجاح بنجاح", vbOKOnly حضور وانصراف موظفين.accdb

في الواقع موضوع واجهات HTML وتوابعها ، شيق وجميل وجديد على الاكسس ، ولكني لاحظت ان الاخ موسى عمل واجهات جميلة بالاكسس ، وببرمجة الاكسس فقط ، ولم يستطع بعض الاعضاء تطبيق الطريقة في برنامجهم ، فرجعوا الى منتدى الاكسس ، وبالاضافة الى الاخ موسى ، قام اعضاء آخرين بالرد على استفساراتهم ، كون البرمجة اكسس. القلق الذي يراودني انه ، في حال استخدام اكواد HTML وتوابعها ، فيصبح معظم الاعضاء الذين سيحاولون تذليل الكود في برامجهم ، سيكون لديهم اساله ، فالسؤال هنا ، من سيقوم بالرد عليهم ويُصلح اخطاءهم؟ لا ننسى اننا في منتدى الاكسس ، فهل نحوّل هذه الاسئلة الى منتدى الويب ، للرد على التساؤلات؟ جعفر

عذرا اخي للتأخير...... تفضل وان شاء الله يكون المطلوب مع اجراء بعض التعديلات Data.accdb

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

وعليكم السلام 🙂 تفضل 🙂 Dim mySQL As String mySQL = "[Date_From]=#" & Me.Date_From & "#" mySQL = mySQL & " And " mySQL = mySQL & "[Date_To]=#" & Me.Date_To & "#" mySQL = mySQL & " And " mySQL = mySQL & "[Car]='" & Me.Car & "'" If DCount("*", "TABLE_NAME", mySQL) > 0 Then MsgBox "تم حجز السيارة بهذا التاريخ سابقا" Exit Sub End If جعفر

ما شاء الله تبارك الله اعانكم الله على ما فيه خير لجميع طالبى العلم ويجعله الله فى ميزان حسانتكم الله ينور استاذ Moosak الله ينور لمعلمنا القدير jjafferr

ممكن .... طيب استبدل الشيفرة بهذا ..... On Error GoTo Errw Dim i As Integer DoCmd.GoToRecord , , acFirst For i = 1 To Me.Recordset.RecordCount If Me.Emp_ABSCENT = False Then Dim Dday As Integer Dday = Weekday(Date_today) If Dday = 5 Then Me.txtTimeIn.Value = Time Me.txtTimeOut = "03:00:00 م" Else Me.txtTimeOut = "04:00:00 م" Me.txtTimeIn.Value = Time End If Else Me.txtTimeIn.Value = "" End If DoCmd.GoToRecord , , acNext Next i Exit Sub Errw: MsgBox "لقد تم اعتماد الانصراف بنجاح", vbOKOnly

هذا مطلبك ؟

حياك الله .... واياك

استبدل الاكواد Option Explicit Sub Test() Dim a, b, x Dim i, ii Dim nmsht, dt, bk Dim p As Long Dim ar As Long Dim tmp, class, br, mat Const c As Integer = 25 Set nmsht = Sheets("name") Set dt = Sheets("data") Set bk = Sheets("Book") b = dt.Range(dt.Range("B4"), dt.Range("B4").End(xlDown)).Resize(, 3) p = 4: For i = 1 To UBound(b) tmp = Split(b(i, 1)) class = IIf(UBound(tmp) < 3, tmp(1), (tmp(0) & " " & tmp(1)) & " " & tmp(2)) br = tmp(UBound(tmp)): mat = b(i, 3) With nmsht.Range("b2:AX400") x = .Find(b(i, 1), , , 1).Address a = .Range(x).Offset(3, -1).Resize(.Range(nmsht.Range(x).Offset(3), nmsht.Range(x).Offset(3).End(xlDown)).Count, 2).Offset(-2, -1) End With ar = 1 With Sheets("book") For ii = 1 To UBound(a) Step c x = Split(.[E:E].Find("-" & p & "-", , , 1).Address, "$")(2) .Cells(x - 6 - c, 4) = .Cells(x - 6 - c, 4) & " " & class .Cells(x - 6 - c, 9) = .Cells(x - 6 - c, 9) & " " & br .Cells(x - 6 - c, 15) = mat .Cells(x - 1 - c, 1).Resize(c, 2) = Application.IfError(Application.Index(a, Evaluate("(Row(" & ar & ":" & ar + c & "))"), Array(1, 2)), "") ar = ar + c p = p + 2 Next End With Next End Sub و Private Sub CommandButton1_Click() Dim r As Range With Sheets("Book") On Error Resume Next For Each myArea In .Columns(1).SpecialCells(2, 1).Areas myArea.Resize(, 2).ClearContents myArea.Offset(-5, 3).Resize(1) = Split(myArea(-4, 4))(0) myArea(-4, 9) = Split(myArea(-4, 9))(0) myArea(-4, 15) = "" Next End With End Sub

تفضل جرب هذا تسيق شرطى معدل1.xlsm

تم الحل بفضل الله باستخدام هذا الاستعلام بدلا من QryFollowUp SELECT qryPlans.PlanSerial, qryPlans.Client, qryPlans.ClcFromDate, qryPlans.ClcToDate, qryPlans.Code, qryPlans.Product, qryPlans.Qty, Nz((select Sum(QtyOut) From qrySales AS T Where T.Code = QryPlans.[Code] And (T.zDate >= qryPlans.[ClcFromDate] And T.zDate <= qryPlans.[ClcToDate])),0) AS Out, [Qty]-Nz((select Sum(QtyOut) From qrySales AS T Where T.Code = QryPlans.[Code] And (T.zDate >= qryPlans.[ClcFromDate] And T.zDate <= qryPlans.[ClcToDate])),0) AS Remains FROM qryPlans; الحل من موقع اجنبى كنت قد عرضت مشكلتى عليه .. جزاكم الله خير

الخطأ ليس من تصدير السجل من النموذج او الجدول بارك الله فيك .... بل من ثبات موقع التصدير ... لانه في الكود يتم التصدير وباستمرار في الخلية A2 ......

اخى ظبط اعدادات الويندوز كما في في هذا الرابط مشكلة اللغه العربية

كسر الحماية يُعتبر مخالف لقوانين المنتدى: اضغط هنـــــــــامن فضلك لقراءة القواعد كاملة يمنع منعا باتا نشر أية مواد تخالف حقوق الملكية الفكرية . 20. يمنع منعا باتا نشر أية موارد تخالف حقوق الملكية الفكرية بما في ذلك الكتب والكراك وتبادل السيريال جعفر

شكرا لك أخي العزيز 😊

السلام عليكم ورحمة الله و بركاته اصدقائي هذا التطبيق هو تطوير لهذا الموضوع في الموضوع السابق كان يجب علينا كتابة اسم السيرفر و اسم قاعدة البيانات ضمن الكود للارتباط بالجداول في هذا التطبيق نستطيع عرض سيرفرات SQL الموجود على الجهاز و اختيار السيرفر و اختيار قاعدة البيانات واختيار نوع الاتصال للارتباط بالجداول طبعا يجب اضافة المرجع SQLDMO.DLL الى البرنامج وهنا يتم اضافة المرجع برمجيا دون اي تدخل من المستخدم الملف SQLDMO.DLL يجب ان يكون في نفس مسار قاعدة البيانات Dim DB As Database Dim RS As Recordset2 Dim TblName As String Dim Td As TableDef ------------------------------------------------------------------------------------------------------------------------------------------- Private Sub chk1_AfterUpdate() If Me.chk1 = True Then Me.TUserName.Enabled = False Me.TPassWord.Enabled = False Else Me.TUserName.Enabled = True Me.TPassWord.Enabled = True End If End Sub ------------------------------------------------------------------------------------------------------------------------------------------- Private Sub Cm1_Click() On Error GoTo ErrSub If IsNull(Me.Comp1) Then MsgBox "يرجى اختيار السيرفر", vbCritical Exit Sub End If If IsNull(Me.Comp2) Then MsgBox "يرجى اختيار اسم قاعدة البيانات", vbCritical Exit Sub End If If Me.chk1 <> 1 And (IsNull(Me.TUserName) Or IsNull(Me.TPassWord)) Then MsgBox "يرجى ادخال اسم المستخدم و كلمة المرور", vbCritical Exit Sub End If For Each Td In CurrentDb.TableDefs If Len(Td.Connect) <> 0 Then CurrentDb.TableDefs.Delete Td.Name End If Next DoCmd.TransferDatabase acImport, "ODBC Database", "ODBC;Driver={SQL Server};Server=" & Me.Comp1 & ";Database=" & Me.Comp2 & ";Trusted_Connection=Yes", acTable, "INFORMATION_SCHEMA.TABLES", "INFORMATION_SCHEMA_TABLES" Set DB = CurrentDb Set RS = DB.OpenRecordset("INFORMATION_SCHEMA_TABLES", dbOpenTable) RS.MoveFirst Do While RS.EOF = False TblName = RS.Fields(2) If Me.chk1 = 1 Then DoCmd.TransferDatabase acLink, "ODBC Database", "ODBC;Driver={SQL Server};Server=" & Me.Comp1 & ";Database=" & Me.Comp2 & ";Trusted_Connection=Yes", acTable, TblName, TblName Else DoCmd.TransferDatabase acLink, "ODBC Database", "ODBC;Driver={SQL Server};Server=" & Me.Comp1 & ";Database=" & Me.Comp2 & ";UID=" & Me.TUserName & ";PWD=" & Me.TPassWord, acTable, TblName, TblName End If RS.MoveNext Loop RS.Close Me.Comp2.RowSource = "" DoCmd.Close acTable, "sysdatabases" DoCmd.DeleteObject acTable, "INFORMATION_SCHEMA_TABLES" DoCmd.DeleteObject acTable, "sysdatabases" MsgBox "تم الارتباط بكافة الجداول بنجاح", vbInformation ErrSub: If Err.Number <> 0 Then MsgBox Err.Number & vbCrLf & Err.Description, vbCritical + vbMsgBoxRight End If End Sub ------------------------------------------------------------------------------------------------------------------------------------------- Private Sub Cm2_Click() Dim i As Integer Dim oNames As SQLDMO.NameList Dim oSQLApp As SQLDMO.Application Dim SysServerCount As Integer Set oSQLApp = New SQLDMO.Application Set oNames = oSQLApp.ListAvailableSQLServers() SysServerCount = oNames.Count Me.Comp1.AllowValueListEdits = True Me.Comp1.RowSourceType = "Value List" If SysServerCount = 0 Then Me.Comp1.RowSource = "local" Else For i = 1 To SysServerCount Me.Comp1.AddItem oNames.Item(i) Next i Me.Comp1.AllowValueListEdits = False End If Me.Comp1.SetFocus Me.Comp1.Dropdown End Sub ------------------------------------------------------------------------------------------------------------------------------------------- Private Sub Comp1_AfterUpdate() On Error GoTo ErrSub DoCmd.TransferDatabase acImport, "ODBC Database", "ODBC;Driver={SQL Server};Server=" & Me.Comp1.Value & ";Database=master;Trusted_Connection=Yes", acTable, "sys.databases", "sysdatabases" Me.Comp2.RowSource = "SELECT sysdatabases.name, sysdatabases.is_auto_close_on FROM sysdatabases WHERE (((sysdatabases.is_auto_close_on)=-1))" Me.Comp2.SetFocus Me.Comp2.Dropdown ErrSub: If Err.Number <> 0 Then End If If Err.Number = 3059 Then MsgBox "تاكد من تشغيل السيرفر", vbCritical + vbMsgBoxRight End If End Sub ------------------------------------------------------------------------------------------------------------------------------------------- Private Sub Form_Close() On Error Resume Next DoCmd.DeleteObject acTable, "sysdatabases" End Sub ------------------------------------------------------------------------------------------------------------------------------------------- Private Sub Form_Load() On Error Resume Next With Access.References .AddFromFile CurrentProject.Path & "\SQLDMO.DLL" End With End Sub Link All Table.rar

تفضل أخي نبيل : nabilDatabase23.accdb

السلام عليكم ورحمة الله وبركاته تفضل اخى رابط اخر على الميديا فاير

يمكن تعديل المسار من خلال محرر الريجيستري قم بالضغط على زري الويندوز + R ثم اكتب regedit واضغط إدخال بما أنك تستخدم أوفيس 2019 انتقل إلى المسار التالي: Computer\HKEY_CURRENT_USER\SOFTWARE\Microsoft\Office\16.0\Outlook\Options (ملاحظة يمكنك نسخ المسار ولصقه مباشرة في محرر الريجيستري للانتقال مباشرة إلى المكان المراد) اضغط في الجهة المقابل بالزر الأيمن واختر (New) ثم String Value قم بتسميته DefaultPath اضغط عليه مرتين وضع مسار الملفات الذي تود أن يفتح عليه الأوت لوك عند رغبتك في حفظ المرفقات أغلاق محرر الريجيستري. وبهذا تكون انتهيت .. وفي المرات المقبلة عند الضغط على زر حفظ .. سيفتح لك مباشرة إلى مجلدك

=screen.activecontrol.value

جرب هذا الماكرو 1- الماكرو يظهر معاينة قبل الطباعة من اجل الطياعة مباشرة استيدل السطر Sh.PrintPreview بالسطر Sh.PrintOut Option Explicit Sub Print_all() Dim Sh As Worksheet Dim k% Application.EnableEvents = False Set Sh = Sheets("الربع") Sh.PageSetup.PrintArea = "$B$2:$L$21" For k = 26 To 81 If Sh.Range("C" & k) <> "" Then Sh.Range("D5") = Sh.Range("C" & k) Sh.PrintPreview 'Sh.PrintOut End If Next k Sh.PageSetup.PrintArea = "" Application.EnableEvents = True End Sub الملف مرفق Alaa.xlsm

تظهر عند فتح البرنامج