استرجاع نسخه احتياطيه من مجلد بجوار القاعده( قاعده مقسمه)

[النجاشي]

السلام عليكم ورحمه الله وبركاته 

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

بدل تالف

تحياتي اليكم احبتي

تم تعديل أكتوبر 29, 2018 بواسطه ابو زاهر

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

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

تم تعديل أكتوبر 29, 2018 بواسطه ابو ياسين المشولي

[النجاشي]

17 ساعات مضت, ابو ياسين المشولي said:

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

استاذي لقد قمت بتجربته وفعلا جميل 

لكنه لا يعمل عندما تكون القاعده مقسمه

تم تعديل أكتوبر 30, 2018 بواسطه ابو زاهر

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

1 ساعه مضت, ابو زاهر said:

استاذي لقد قمت بتجربته وفعلا جميل 

لكنه لا يعمل عندما تكون القاعده مقسمه

اتفضل هذا حسب طلبك

لتعم الفائده

نعمل وحده نمطيه

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

 

 

تم تعديل أكتوبر 30, 2018 بواسطه ابو ياسين المشولي

[النجاشي]

15 دقائق مضت, ابو ياسين المشولي said:

اتفضل هذا حسب طلبك

لتعم الفائده

 

 

C.rar

ممتاز بارك الله فيك نور الله دربك يالغالي نعم هو المطلوب

[ابوآمنة]

شكراً لكم 

كيف استدعي الوحدة النمطية ( المديول ) 

أريد الحدث الذي خلف الزر لاستدعائها ,
أو أرفاق مثال

 

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

54 دقائق مضت, saleh204 said:

شكراً لكم 

كيف استدعي الوحدة النمطية ( المديول ) 

أريد الحدث الذي خلف الزر لاستدعائها ,
أو أرفاق مثال

 

تستدعيها هنا

Call ImportRelations(myfile)

وهنا
تسدعي حذف 
delRelTbl