عمل نسخة من قاعدة البيانات للجداول فقط

النهر العطشان · مايو 28, 2017

رمضان كريم اعاده الله علينا وعليكم والامة الاسلامية بالخير والبركة

السلام عليكم

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

المطلوب هو التعديل عليها ليكون عمل النسخة للجداول فقط .

وشكرا

copy tables only.rar

**ابوخليل** · مايو 28, 2017

وعليكم السلام

قليلا من البحث جزاكم الله خيرا

هذا الرابط فيه اخذ نسخة من الجداول واسترجاعها ايضا

النهر العطشان · مايو 28, 2017

السلام عليكم استاذ ابوخليل

استاذي الفاضل لقد شاهدت تلك القواعد في الرابط المرسل من قبلكم ومن قبل شاهدتها .

وان تلك الطرق لاتخدمني في عملي في بعض البرامج التي تتعامل مع قواعد البيانات .

اما الطريقة الموجوده في الملف المرفق من قبلي اعلاه .

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

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

وشكرا

النهر العطشان · مايو 28, 2017

رمضان كريم

السلام عليكم

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

**رمهان** · مايو 28, 2017

بعد اذن الاستاذ ابو خليل

هل تريد مع العلاقات ام بدون ؟ اي انشاء نسخة من الجداول والبيانات بدون العلاقات ؟

النهر العطشان · مايو 28, 2017

السلام عليكم

استاذي الفاضل احتاج نسخه من الجداول مع العلاقات

ولكم جزيل الشكر

تم تعديل مايو 28, 2017 بواسطه النهر العطشان

**Shivan Rekany** · مايو 28, 2017

في 28‏/5‏/2017 at 19:29, النهر العطشان said:

استاذي الفاضل احتاج نسخه من الجداول مع العلاقات

Expand

استأذن من استاذنا @ابوخليل و @رمهان

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

الصق هذا في وحدة نمطية

Option Compare Database
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Public Function ExportNew(myfile As String)
' إنشاء  ملف جديد
Dim wrkDefault As Workspace
Dim dbsNew As Database
Dim mydb
On Error GoTo gv
mydb = Dir(myfile)
If mydb = "" Then
Set wrkDefault = DBEngine.Workspaces(0)
Set dbsNew = wrkDefault.CreateDatabase(myfile, dbLangArabic)
Call exportTbl(myfile)
GoTo gv1
Else
Call exportTbl(myfile)
GoTo gv1
End If
gv:
Resume
gv1:
End Function

Public Function exportTbl(myfile As String)
 'تصدير  نسخة لجميع الجداول الموجودة'
 Dim tdfCurr As TableDef
 Dim strBackupDatabase As String
 strBackupDatabase = myfile
 For Each tdfCurr In CurrentDb().TableDefs
 If (tdfCurr.Attributes And dbSystemObject) = 0 Then
 DoCmd.TransferDatabase acExport, "Microsoft Access", _
 strBackupDatabase, acTable, tdfCurr.Name, _
 tdfCurr.Name
    End If
   Next tdfCurr
End Function
Function ExportRelations(DbName, DbName2 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(DbName2)
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
ExportRelations = RCount
End Function


Public Sub autobackup()
Dim datefile As Date
Dim timefile As Date
Dim pro As String

datefile = Date
timefile = Time

pro = Mid(CurrentProject.Name, 1, (Len(CurrentProject.Name) - 4)) & "   " & _
Format(datefile, "yyyy-mm-dd") & "   " & Format(timefile, "hh-nn-ss")

Path = "D:\Backup\"
x = Path
Select Case x
End Select
    
MakeSureDirectoryPathExists Path & "\"

Call ExportNew(x & "\" & pro & ".dat")
Call ExportRelations(CurrentProject.FullName, x & "\" & pro & ".dat")

MsgBox "تم انشاء نسخة احتياطية بشكل آلي بنجاح في المسار" & vbCrLf & "D:\Backup\", vbInformation

End Sub

وفي نموذج خلف زر اكتب هذا

Call autobackup

تم تعديل مايو 28, 2017 بواسطه Shivan Rekany

**رمهان** · مايو 28, 2017

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

النهر العطشان · مايو 28, 2017

السلام عليكم

استاذي الفاضل الكود الذي تفضلت بكتابته لايتوافق مع مطلبي واشكر سعيك بما تفضلت به فهو يقوم بعمل Backup_tables.

عنوان مطلبي هو : عمل نسخة من قاعدة البيانات للجداول فقط

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

المطلوب هو التعديل عليها ليكون عمل النسخة للجداول فقط .

الغرض من مطلبي هو في حالة طلب نسخه من البيانات فيمكنني اعطاءها بدون الفورم والاكواد , اي اعطاء نسخه من الجداول فقط

واتمنى التعديل على الملف المرفق والذي عند الضغط على زر (نسخه من الجداول فقط) ليعمل نسخه من الجداول فقط .

وشكرا

copy tables only.rar

**محمد سلامة** · مايو 28, 2017

السلام عليكم

وبعد اذن استاذي @ابوخليل و @رمهان و @Shivan Rekany

**ابوخليل** · مايو 29, 2017

في 28‏/5‏/2017 at 20:23, النهر العطشان said:

عنوان مطلبي هو : عمل نسخة من قاعدة البيانات للجداول فقط

Expand

كل الحلول اعلاه لعمل نسخة من قاعدة الجداول فقط

النهر العطشان · مايو 30, 2017

رمضان كريم

السلام عليكم

الى الاساتذه الكرام والى القيمين على هذا الموقع المحترمين .

طلبي هو التعديل على الكود في الملف المرفق حيث عند الضغط على زر (نسخه من الجداول فقط) يقوم بعمل نسخه كامله لقاعدة البيانات .

طلبي واضح وهو التعديل على نفس الكود ليقوم عند الضغط على رز (نسخه من الجداول فقط) يقوم بعمل نسخه للجداول فقط .

واكون شاكرا لمن لبى طلبي

copy tables only.rar

Ibrahim IQ · مايو 30, 2017

في 28‏/5‏/2017 at 19:48, Shivan Rekany said:

استأذن من استاذنا @ابوخليل و @رمهان

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

الصق هذا في وحدة نمطية

Option Compare Database
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Public Function ExportNew(myfile As String)
' إنشاء  ملف جديد
Dim wrkDefault As Workspace
Dim dbsNew As Database
Dim mydb
On Error GoTo gv
mydb = Dir(myfile)
If mydb = "" Then
Set wrkDefault = DBEngine.Workspaces(0)
Set dbsNew = wrkDefault.CreateDatabase(myfile, dbLangArabic)
Call exportTbl(myfile)
GoTo gv1
Else
Call exportTbl(myfile)
GoTo gv1
End If
gv:
Resume
gv1:
End Function

Public Function exportTbl(myfile As String)
 'تصدير  نسخة لجميع الجداول الموجودة'
 Dim tdfCurr As TableDef
 Dim strBackupDatabase As String
 strBackupDatabase = myfile
 For Each tdfCurr In CurrentDb().TableDefs
 If (tdfCurr.Attributes And dbSystemObject) = 0 Then
 DoCmd.TransferDatabase acExport, "Microsoft Access", _
 strBackupDatabase, acTable, tdfCurr.Name, _
 tdfCurr.Name
    End If
   Next tdfCurr
End Function
Function ExportRelations(DbName, DbName2 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(DbName2)
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
ExportRelations = RCount
End Function


Public Sub autobackup()
Dim datefile As Date
Dim timefile As Date
Dim pro As String

datefile = Date
timefile = Time

pro = Mid(CurrentProject.Name, 1, (Len(CurrentProject.Name) - 4)) & "   " & _
Format(datefile, "yyyy-mm-dd") & "   " & Format(timefile, "hh-nn-ss")

Path = "D:\Backup\"
x = Path
Select Case x
End Select
    
MakeSureDirectoryPathExists Path & "\"

Call ExportNew(x & "\" & pro & ".dat")
Call ExportRelations(CurrentProject.FullName, x & "\" & pro & ".dat")

MsgBox "تم انشاء نسخة احتياطية بشكل آلي بنجاح في المسار" & vbCrLf & "D:\Backup\", vbInformation

End Sub

وفي نموذج خلف زر اكتب هذا

Call autobackup

Expand

شكرا استاذ شفان وهذا عمل رائع .... وماذا عن استرجاع الجداول ؟؟؟

النهر العطشان · مايو 30, 2017

رمضان كريم

شكرا استاذ Rebaz Bahram على سرعة الاجابة

استاذي انا لا احتاج الى نسخه backup للجداول .

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

واتمنى ان يتم التعديل على النسخه المرفوعه من قبلي .

وشكرا

**Shivan Rekany** · مايو 30, 2017

في 30‏/5‏/2017 at 21:50, النهر العطشان said:

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

Expand

اخي العزيز
كل الطرق الاعلاه بيوصلك الى مطلبك

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

واختر اوبين وبعدين اختر ذاك الملف اللي بيعطيك نتيجة باك اب

او اضغط كليك يمين على تلك الملف اللي وصات اليه بواسطة باك اب

واختر فتح بواسطة

بعدين اختر اخرى

سيفتح لك النافذة

بعدين اختار بواسطة اكسس

**ابوخليل** · مايو 31, 2017

غريب جدا الحلول كلها امامك

يمكن انك لم تطرح سؤالك بالطريقة المناسبة الصحيحة

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

Ibrahim IQ · مايو 31, 2017

اخى @النهر العطشان اتمنى هذا المطلوب مع الشكر

لعلم : سيحفظ في (D) فولدر (backup)

backup tables.rarFetching info...

تم تعديل مايو 31, 2017 بواسطه Rebaz Bahram

النهر العطشان · يونيو 1, 2017

السلام عليكم

شكرا استاذ Rebaz Bahram على اهتمامكل واجابتك .

لقد جربت هذه الطريقة ونجحت معي ولكن عند نقل الكود والمديول على برنامج اخر ضهرت لي هذه المشكلة وشكرا

Ibrahim IQ · يونيو 1, 2017

في 1‏/6‏/2017 at 20:47, النهر العطشان said:

السلام عليكم

شكرا استاذ Rebaz Bahram على اهتمامكل واجابتك .

لقد جربت هذه الطريقة ونجحت معي ولكن عند نقل الكود والمديول على برنامج اخر ضهرت لي هذه المشكلة وشكرا

Download Image

Expand

جرب هذا اتمنى ليس لديها المشكلة ... تحياتى

Rebaz Backup.accdb.rar

النهر العطشان · يونيو 2, 2017

السلام عليكم رمضان كريم

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

ولكن هنالك امران :

1- اين يتم تغيير اسماء الجداول في الكود ليعمل الكود في برامج اخرى .

2- هذه الطريقة لاتخدم العلاقات في الجداول .

وشكرا

Ibrahim IQ · يونيو 2, 2017

في 2‏/6‏/2017 at 21:37, النهر العطشان said:

السلام عليكم رمضان كريم

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

ولكن هنالك امران :

1- اين يتم تغيير اسماء الجداول في الكود ليعمل الكود في برامج اخرى .

2- هذه الطريقة لاتخدم العلاقات في الجداول .

وشكرا

Expand

وعليكم السلام اخي الكريم

بالنسبة للمرفق الثاني

1- لا حاجة لتغير اسماء الجداول في الاكواد ولكن يحتاج ان اكتب اسماء الجداول في الجدول (OptNaskh) وبعد كل اسم اكتب علامة ;

مثلا قاعدة بياناتك لده 20 جدول وانت بحاجة الى ان ينسخ 10 فقط اكتب اسم 10 . اما لقاعدة بيانات اخرى فقط غير اسم الجداول في هذا الحقل و بعدهم علامة (;)

2- هذه الطريقة سيحذف كل العلاقان و يصنعه بنفسه تلقائيا كما كان سابقا .

تحياتى لك

النهر العطشان · يونيو 3, 2017

السلام عليكم

شكرا استاذنا الفاضل Rebaz Bahram على الاجابة وتقديرا لك على كل ماتقوم به من عطاء .

جعلها الله في ميزان حسناتك .

dr_ghost · يونيو 5, 2017

في 28‏/5‏/2017 at 19:48, Shivan Rekany said:

استأذن من استاذنا @ابوخليل و @رمهان

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

الصق هذا في وحدة نمطية

Option Compare Database
Private Declare Function MakeSureDirectoryPathExists Lib "imagehlp.dll" (ByVal lpPath As String) As Long

Public Function ExportNew(myfile As String)
' إنشاء  ملف جديد
Dim wrkDefault As Workspace
Dim dbsNew As Database
Dim mydb
On Error GoTo gv
mydb = Dir(myfile)
If mydb = "" Then
Set wrkDefault = DBEngine.Workspaces(0)
Set dbsNew = wrkDefault.CreateDatabase(myfile, dbLangArabic)
Call exportTbl(myfile)
GoTo gv1
Else
Call exportTbl(myfile)
GoTo gv1
End If
gv:
Resume
gv1:
End Function

Public Function exportTbl(myfile As String)
 'تصدير  نسخة لجميع الجداول الموجودة'
 Dim tdfCurr As TableDef
 Dim strBackupDatabase As String
 strBackupDatabase = myfile
 For Each tdfCurr In CurrentDb().TableDefs
 If (tdfCurr.Attributes And dbSystemObject) = 0 Then
 DoCmd.TransferDatabase acExport, "Microsoft Access", _
 strBackupDatabase, acTable, tdfCurr.Name, _
 tdfCurr.Name
    End If
   Next tdfCurr
End Function
Function ExportRelations(DbName, DbName2 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(DbName2)
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
ExportRelations = RCount
End Function


Public Sub autobackup()
Dim datefile As Date
Dim timefile As Date
Dim pro As String

datefile = Date
timefile = Time

pro = Mid(CurrentProject.Name, 1, (Len(CurrentProject.Name) - 4)) & "   " & _
Format(datefile, "yyyy-mm-dd") & "   " & Format(timefile, "hh-nn-ss")

Path = "D:\Backup\"
x = Path
Select Case x
End Select
    
MakeSureDirectoryPathExists Path & "\"

Call ExportNew(x & "\" & pro & ".dat")
Call ExportRelations(CurrentProject.FullName, x & "\" & pro & ".dat")

MsgBox "تم انشاء نسخة احتياطية بشكل آلي بنجاح في المسار" & vbCrLf & "D:\Backup\", vbInformation

End Sub

وفي نموذج خلف زر اكتب هذا

Call autobackup

Expand

ماذا عن استيراد هذه الجداول auto restore

تسجيل الدخول

عمل نسخة من قاعدة البيانات للجداول فقط

الردود الموصى بها

النهر العطشان

ابوخليل

النهر العطشان

النهر العطشان

رمهان

النهر العطشان

Shivan Rekany

رمهان

النهر العطشان

محمد سلامة

ابوخليل

النهر العطشان

Ibrahim IQ

النهر العطشان

Shivan Rekany

ابوخليل

Ibrahim IQ

النهر العطشان

Ibrahim IQ

النهر العطشان

Ibrahim IQ

النهر العطشان

dr_ghost

Join the conversation

تصفح هذا الموضوع مؤخراً 0 اعضاء متواجدين الان

تصفح الموقع

تصفح جديد الموقع

Support

Important Information