ابو ياسين المشولي

راجع هذا

ليس هكذا شوف نموذج date04 للتدريب.accdb

بس لازم تحدد نموذج في تاريخ

فين تبغا الرصيد السابق حدد

اتفضل هذا حسب طلبك لتعم الفائده نعمل وحده نمطيه Option Compare Database Public myfile As String Public Function delTbl() Dim strdb As String Dim dbs As DAO.Database Dim tdf As TableDef strdb = Application.CurrentProject.Path & "\bb" Set dbs = OpenDatabase(strdb) On Error Resume Next For Each tdf In dbs.TableDefs If Not (left(tdf.name, 4)) = "MSys" Then dbs.Execute ("delete * from " & tdf.name) End If Next Set dbs = Nothing End Function Public Function delRelTbl() Dim strdb As String Dim dbs As DAO.Database Dim tdf As TableDef strdb = Application.CurrentProject.Path & "\bb" Set dbs = OpenDatabase(strdb) On Error Resume Next With dbs For Each rel In .Relations .Relations.delete rel.name Next .Relations.Refresh End With dbs.Close Set dbs = Nothing End Function Public Function ImportTbl() Dim db As Database Dim StrSql As String Dim tdf As TableDef Dim strPath As String Dim BackDB As DAO.Database strPath = Application.CurrentProject.Path & "\bb" Set BackDB = OpenDatabase(strPath) For Each tdf In BackDB.TableDefs If Not (left(tdf.name, 4)) = "MSys" Then BackDB.Execute ("delete * from " & tdf.name) StrSql = "INSERT INTO " & tdf.name & " SELECT " & tdf.name & ".* FROM " & tdf.name & " IN '" & myfile & "';" BackDB.Execute (StrSql) End If Next tdf Set db = Nothing End Function Function ImportRelations(DbName As String) As Integer Dim ThisDB As DAO.Database, ThatDB As DAO.Database Dim ThisRel As DAO.Relation, ThatRel As DAO.Relation Dim ThisField As DAO.Field, ThatField As DAO.Field Dim cr As String, i As Integer, cnt As Integer, RCount As Integer Dim j As Integer Dim ErrBadField As Integer cr$ = Chr$(13) RCount = 0 Set ThisDB = DBEngine.Workspaces(0).OpenDatabase(Application.CurrentProject.Path & "\bb") Set ThatDB = DBEngine.Workspaces(0).OpenDatabase(DbName$) For i = 0 To ThatDB.Relations.Count - 1 Set ThatRel = ThatDB.Relations(i) Set ThisRel = ThisDB.CreateRelation(ThatRel.name, _ ThatRel.Table, ThatRel.ForeignTable, ThatRel.Attributes) ErrBadField = False For j = 0 To ThatRel.Fields.Count - 1 Set ThatField = ThatRel.Fields(j) Set ThisField = ThisRel.CreateField(ThatField.name) ThisField.ForeignName = ThatField.ForeignName On Error Resume Next ThisRel.Fields.Append ThisField If err <> False Then ErrBadField = True On Error GoTo 0 Next j If ErrBadField = True Then Else On Error Resume Next ThisDB.Relations.Append ThisRel If err <> False Then Else RCount = RCount + 1 End If On Error GoTo 0 End If Next i ThisDB.Close ThatDB.Close ImportRelations = RCount End Function ثم نعمل كود في زر الامر On Error GoTo MyErr Dim wrkJet As Workspace Dim AbA As Database Dim tbl As TableDef Dim Path, myfile As String Dim varItem As Variant With Application.FileDialog(msoFileDialogFilePicker) .Title = "اختر الملف المراد نسخه" If .Show Then For Each varItem In .SelectedItems myfile = varItem Next varItem End If End With If Len(myfile & "") > 0 Then If MsgBox("يترتب على استرجاع البيانات المحددة حذف البيانات الحالية" _ & vbCrLf & "ويستحسن عمل نسخة من البيانات الحالية قبل الاسترجاع " _ & vbCrLf & vbCrLf & "هل أنت متأكد من أنك تود استبدال البيانات الحالية بالبيانات المسترجعة " _ , 590132, "تنبيه ") = 7 Then Exit Sub Set wrkJet = DBEngine.Workspaces(0) Set AbA = wrkJet.OpenDatabase(myfile, False, False, ";PWD=123456") Dim StrSql As String Dim tdf As TableDef Dim BackDB As DAO.Database Dim strPath As String strPath = Application.CurrentProject.Path & "\bb" Set BackDB = OpenDatabase(strPath) For Each tdf In BackDB.TableDefs If Not (left(tdf.name, 4)) = "MSys" Then delRelTbl BackDB.Execute ("delete * from " & tdf.name) StrSql = "INSERT INTO " & tdf.name & " SELECT " & tdf.name & ".* FROM " & tdf.name & " IN '" & myfile & "';" BackDB.Execute (StrSql) End If Next tdf MsgBox " تـــم استرجـــــاع بيــــانات النسخـــــــه المحــــــدده ", vbInformation, Space(5) & " : استرجاع بيانات " End If CurrentDb.TableDefs.Refresh Call ImportRelations(myfile) CurrentDb.Close Me.Refresh

راجع هذا اضغط هنا

حولها الى mde او accde

عندك خطاء بكود بفورم تعديل فاتورة بيع اتبع الاخطاء وبتلاقيه

للرفع

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

راجع هذا الموضوع اضغط هنا

جرب هذا On Error Resume Next Call zr_11_Click Set RS = CurrentDb.OpenRecordset("AfwtIar") RS.AddNew RS!Rjmfatwra = Rjmfatwra RS!NoEmp = NoEmp RS!Nwaha = Nwaha RS!Adfah = Adfah RS!Alban = Alban RS!Atarih = Atarih RS!namee = namee RS!Aljmali = Me.n1 RS!Asafi = Me.n2 RS.Update Rjmfatwra = Null NoEmp = Null Adfah = Null Nwaha = Null Namamila = Null Alban = Null Atarih = Null 'namee = Null Set RS = Nothing DoCmd.SetWarnings False DoCmd.OpenQuery "الحاق" DoCmd.SetWarnings True '' 'On Error Resume Next Dim Q As Recordset Set Q = CurrentDb.OpenRecordset("SELECT * FROM HRR;") While Not Q.EOF 'If Q!Xsave = False Then Me.TB.Visible = False Q.Delete 'End If Q.MoveNext Wend TB.Requery Me.TB.Visible = True

جرب هذا عند الاغلاق لعل جهازي سريع ههههههههه Call ZR_9_Click لديك موضوع هنا بنفس المشكله

الفيديو بيني وبنك bandicam 2018-10-28 22-01-58-379.rar

لم الحظ شي

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

لكني اخي ابوأسد لا اريد عمل للبرنامج انا اريد عمل الرقم للقاعده الخلفيه وحبيت اعدل عليها لن استطيع لازم اي مغترع او مبرمج او او يكون لديه حل لمثل هذا وليس بدون حل اني احتفظ بنسخه accdb فهنا كاني لم اعمل شي شكرا لك

؟؟؟؟؟؟؟؟؟؟

انا هنا لست لتحدي انا اتكلم على موضوعك السابق كيف اذا اردت على التعديل بعد عمل رقم سري

كيف اذا اردنا ان نفتح القاعده لتعديل

عند الفتح او عند التحميل كما يحلو لك

بالتوفيق اخي ابو زاهر

اتفضل LoadKeyboardLayout "00000401", 1

لم تجيب بعد هل ضبط معك الكود ام لا

بالتوفيق الله يوفقك ونشوف مواضيع جديدة ومهمه