سوال : طریقه انتقال جداول اکسس به بانکی دیگر به همراه ارتباط بین آنها (relationship)

[najafi87]

سلام خدمت اساتید عزیز
آیا راهی است تا بتونیم جداول اکسس رو به همراه ارتباط بین آنها (relationship) به بانکی دیگه انتقال بدیم؟

[mazoolagh]

وقتی دو جدول مرتبط از یک دیتابیس دیگه ایمپورت میشن خودکار رابطه شون هم ساخته میشه

[najafi87]

سلام ممنون از راهنماییتون
اما من میخوام با یه فرمان جداول و ارتباطشون رو از داخل همون فایل به فایل دیگه ای منتقل کنم درواقع مثل یه حالت backup.

[mazoolagh]

پس منظورتون با کدنویسی vba هست. کدش قدری پیچیده هست به همین خاطر یک توضیح میدم.

اول با DOCMD.TRANSFERDATABASE جداول مرتبط رو مثل جداول معمولی IMPORT میکنین.

بعد دیتابیس اصلی رو باز میکنین و در رابطه هاش دنبال رابطه ای میگردین که مشخصاتش با جداول بخونه.
اگر این رابطه وجود داشته باشه یک رابطه جدید میسازین و تمام مشخصات رابطه رو در اون کپی میکنین.
نهایتا رابطه جدید رو به دیتلبیس خودتون اضافه میکنین.

همین!


Dim DBS_NAME As String
DBS_NAME = "DRIVE:\FOLDER\DATABASE.accdb"

Dim MAIN_TABLE, SUB_TABLE As String
MAIN_TABLE = "TBL1"
SUB_TABLE = "TBL2"

DoCmd.TransferDatabase acImport, "Microsoft Access", DBS_NAME, acTable, MAIN_TABLE, MAIN_TABLE
DoCmd.TransferDatabase acImport, "Microsoft Access", DBS_NAME, acTable, SUB_TABLE, SUB_TABLE

Dim DBS As Database
Set DBS = OpenDatabase(DBS_NAME)

Dim SREL As Relation
Dim DREL As Relation
Dim FLD As Field

For Each SREL In DBS.Relations
If SREL.Table = MAIN_TABLE And SREL.ForeignTable = SUB_TABLE Then
Set DREL = CurrentDb.CreateRelation(SREL.Name, SREL.Table, SREL.ForeignTable, SREL.Attributes)
For Each FLD In SREL.Fields
DREL.Fields.Append DREL.CreateField(FLD.ForeignName)
DREL.Fields(FLD.Name).ForeignName = FLD.ForeignName
Next
CurrentDb.Relations.Append DREL
Exit For
End If
Next
DBS.Close
Set DBS = Nothing

[abdoreza57]

با سلام


ضمن جستجوی تالار به این تاپیک برخوردم ! هر چند زمانش منقضی شده ولی با راهکار دوست عزیزمون مشکلم حل نمیشه
در نظر داشتم با ایجاد دیالوگ باکس و انتخاب فایل مبدا تمام جداول به همراه ارتباطات به داخل فایل مقصد که یک دیتابیس خالی هست منتقل بشه
چند راه رو رفتم نتونستم اگه دوستان لطف کنند ممنون میشم

در حال حاضر من تو فایل مقصد یک فرم قرار داده ام با یک دکمه که با کلیلک بر روی آن تمام جدول و ارتباطات از فایل مبدا به داخل فایل مقصد انتقال می یابد

خدا نگهدار

[mazoolagh]

الآن مشخص نکردین که مشکلتون دقیقا کجاست؟
اینکه اتوماتیک تمام جداول رو بیاره یا اینکه کد اشکال داره. اگر حالت اول هست که باید یک حلقه بیرونی دیگه برای پیمایش جدول ها اضافه کنین.

[abdoreza57]

سلام

دوست عزیز متاسفم که نتونستم منظورم را واضح برسونم ...
بله میخوام تمام جداول را بیاره داخل برنامه مد نظرم فرض کنید فرمی هست تو یه دیتابیس خالی که به کلیک روی باتومی دیالوگ باکسی باز بشه و با انتخاب کردن فایل مورد نظر تمام جداول با روابطش به داخل فایل خودمون وارد بشند

دقیقا همون کاری که با راست کلیک کردن و انتخاب ایمپورت حاصل میشه منتها اینبار با شرایطی که شرح دادم

یا حق

[Abbas Amiri]

سلام
با تشکر از راهنمایی جناب mazoolagh ، کدهای زیر رو دریک ماژول کپی کنید و تابع ImportTablesAndRelations رو صدابزنید


Function ImportTablesAndRelations(strSourcePath As String) As Boolean
If Not ImportTables(strSourcePath) Then
MsgBox "Error when import tables"
Exit Function
End If
If Not ImportRelations(strSourcePath) Then
MsgBox "Error when import relations"
Exit Function
End If
MsgBox "All tables and relation Imported successfully"
ImportTablesAndRelations = True
End Function

Private Function ImportRelations(strSourcePath As String) As Boolean
Dim db As Database
Dim dbSource As Database
Dim rel As DAO.Relation
Dim fld As DAO.Field
Dim RelSource As DAO.Relation
Dim i As Integer, j As Integer, fldName As String
On Error GoTo ErrH
Set db = CurrentDb
Set dbSource = OpenDatabase(strSourcePath)

For i = dbSource.Relations.Count - 1 To 0 Step -1
Set RelSource = dbSource.Relations(i)
Set rel = db.CreateRelation(RelSource.Name, RelSource.Table, RelSource.ForeignTable, RelSource.Attributes)
For j = 0 To RelSource.Fields.Count - 1
fldName = RelSource.Fields(j).Name
rel.Fields.Append rel.CreateField(fldName)
rel.Fields(fldName).ForeignName = RelSource.Fields(j).ForeignName
Next
db.Relations.Append rel
Next
ImportRelations = True
Exit Function
ErrH:
If Err.Number = 3284 Then 'Index already exists
Resume Next
Else
Stop
End If
End Function

Private Function ImportTables(strSourcePath As String) As Boolean
Dim db As Database
Dim tdf As DAO.TableDef

On Error GoTo ErrH
Set db = OpenDatabase(strSourcePath)
For Each tdf In db.TableDefs
If tdf.Attributes = 0 Then
If DCount("*", "MSysObjects", "Name='" & tdf.Name & "' AND Type=1") > 0 Then
DeleteRelation tdf.Name
DoCmd.DeleteObject acTable, tdf.Name
End If
DoCmd.TransferDatabase acImport, "Microsoft Access", strSourcePath, acTable, tdf.Name, tdf.Name
End If
Next
Set db = Nothing
ImportTables = True
Exit Function
ErrH:

End Function

Private Sub DeleteRelation(tblName As String)
Dim rel As Relation
For Each rel In CurrentDb.Relations
'rel.Attributes
If rel.ForeignTable = tblName Or rel.Table = tblName Then
CurrentDb.Relations.Delete rel.Name
End If
Next
End Sub

[abdoreza57]

سلام

از عنایت شما سپاسگذارم شاید اون چیزی که مد نظر منه با آنچه شما زحمتش را کشیدید متفاوت باشه منتها هر کاری میکنم نمیتونم با این فانکشن کار کنم !
خطا میگیره چیزی که میخوام نتیجه اش انتقال جداول و ارتباطات آنها به فایل دیگه باشه تو خود دیتابیس اکسس با import راست کلیک به راحتی امکان پذیره ولی چرا با کد نویسی اینقدر پیچیده میشه ؟

ضمن اینکه فایل مورد نظرم به این ترتیبی هست که ضمیمه میکنم خوشحال میشم اگه راهنمایی فرمایید

دوستون دارم

[Abbas Amiri]

سلام
جهت فراخوانی یک تابع یا روال باید به آرگومانهای آن هم توجه کرد. مورد زیر را تغییر دهید:


Private Sub Command0_Click()
ImportTablesAndRelations CurrentProject.Path & "\Database.mdb"
End Sub


همچنین در کدهای پست قبلی خط 21 را مطابق زیر تغییر دهید


On Error Resume Next

[abdoreza57]

با سلام

من نمونه فوق را وقتی آدرس دهی میکنم خطا میگیره !
کدی که برای فراخوانی فایل ایجاد کردم احتمالا ایراد داره اگه لطف کنید و راهنمایی ممنون میشم

On Error Resume Next
Dim strSelectedPath As Variant
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.ButtonName = "انتخاب"
fd.Title = "مسیر فایل مبدا را معین کنید "
fd.Show
strSelectedPath = CStr(fd.SelectedItems.Item(1))
Me.Adres = strSelectedPath

ImportTablesAndRelations CurrentProject.path & "strSelectedPath"


خدا نگهدار

[Abbas Amiri]

با سلام

من نمونه فوق را وقتی آدرس دهی میکنم خطا میگیره !
کدی که برای فراخوانی فایل ایجاد کردم احتمالا ایراد داره اگه لطف کنید و راهنمایی ممنون میشم

On Error Resume Next
Dim strSelectedPath As Variant
Dim fd As Office.FileDialog
Set fd = Application.FileDialog(msoFileDialogFilePicker)
fd.ButtonName = "انتخاب"
fd.Title = "مسیر فایل مبدا را معین کنید "
fd.Show
strSelectedPath = CStr(fd.SelectedItems.Item(1))
Me.Adres = strSelectedPath

ImportTablesAndRelations CurrentProject.path & "strSelectedPath"


خدا نگهدار

برای استفاده از FileDialog رفرنس Microsoft Office 1x.0 Library را اضافه کنید

[abdoreza57]

برای استفاده از FileDialog رفرنس Microsoft Office 1x.0 Library را اضافه کنید
سلام
جناب امیری فانکشن تو این قسمت متوقف میشه !

If Not ImportTables(strSourcePath) Then
MsgBox "Error when import tables"
با همون پیغام
درمورد راهکارتون هم من اون رفرنس را اضافه کرده بودم ، به نظرم مشکل تو این قسمت کد بود که آرگومان را معرفی میکنه! شاید تو پس و پیش بودن باشه ولی من امتحان کردم نشد

ImportTablesAndRelations CurrentProject.path & "strSelectedPath"
منتظر جوابتون هستم اگه نیاز هست نمونه را پست کنم
خدا نگهدار

[Abbas Amiri]

سلام
جناب امیری فانکشن تو این قسمت متوقف میشه !

If Not ImportTables(strSourcePath) Then
MsgBox "Error when import tables"
با همون پیغام
درمورد راهکارتون هم من اون رفرنس را اضافه کرده بودم ، به نظرم مشکل تو این قسمت کد بود که آرگومان را معرفی میکنه! شاید تو پس و پیش بودن باشه ولی من امتحان کردم نشد

ImportTablesAndRelations CurrentProject.path & "strSelectedPath"
منتظر جوابتون هستم اگه نیاز هست نمونه را پست کنم
خدا نگهدار

strSelectedPath نام متغیره و نباید در دبل کوتیشن قرار بگیره و مقدار برگشتی FileDialog آدرس کامل مسیر است. قالب صحیح باید بصورت زیر باشد:

ImportTablesAndRelations strSelectedPath

اگر مشکلی بود فایلتان را ضمیمه کنید

[abdoreza57]

با سلام

دقیقا همین کد و دستور را من تو برنامه دیگه دارم استفاده میکنم (در صورت به روزرسانی فرمها و اینترفیس برنامه کلیه جداول قبلی را با همین فرمان جایگزین میکنم و تمام !)

ولی تو این نمونه نمیدونم کدها مشکل دارند یا خودم !:گیج: یه بار انجام میده دفعه بعد مشکل بوجود میاد باید چند بار کلیک کنی تا مشکل حل بشه ....!!!

این هم نمونه خدمت شما که متاسفاته با فراخوانی فایل امکان این عملیات هم از دست میره !!!

خدا نگهدار

[Abbas Amiri]

با سلام

دقیقا همین کد و دستور را من تو برنامه دیگه دارم استفاده میکنم (در صورت به روزرسانی فرمها و اینترفیس برنامه کلیه جداول قبلی را با همین فرمان جایگزین میکنم و تمام !)

ولی تو این نمونه نمیدونم کدها مشکل دارند یا خودم !:گیج: یه بار انجام میده دفعه بعد مشکل بوجود میاد باید چند بار کلیک کنی تا مشکل حل بشه ....!!!

این هم نمونه خدمت شما که متاسفاته با فراخوانی فایل امکان این عملیات هم از دست میره !!!

خدا نگهدار

این مسئله بشدت بنده رو با چالش روبرو کرد و در آخر هم مطلوبیت لازم ایجاد نشد . فایل ضمیمه مشکلات خیلی کمتری نسبت به قبلی دارد

[hamid-nice]

این مسئله بشدت بنده رو با چالش روبرو کرد و در آخر هم مطلوبیت لازم ایجاد نشد . فایل ضمیمه مشکلات خیلی کمتری نسبت به قبلی دارد
1-عدم مطلوبیت لازم چی بود ؟ ما که نفهمیدیم!
2-اگه ممکنه در مورد کار دستور lblWarn کمی توضیح دهید ؟
با تشکر

[Abbas Amiri]

1-عدم مطلوبیت لازم چی بود ؟ ما که نفهمیدیم!
2-اگه ممکنه در مورد کار دستور lblWarn کمی توضیح دهید ؟
با تشکر

منظورم از عدم مطلوبیت لازم استفاده از این قسمت کد ها بود

ErrH:
If Err = 3167 Then
Resume 0
End If

که به هر طریقی جلوگیری از بروز خطا میسر نشد و چناچه تعدا جداول و ارتباطات زیاد باشد ، بعضی مواقع زمان گیر خواهد بود

lblWarn هم نام یک کنترل Label هست که پیغام "درحال انتقال جداول پشتیبان" رو نمایش می دهد