درخواست کمک برای نوشتن کد پشتیبان [بایگانی]

evilboy

یک شنبه 05 آذر 1385, 19:14 عصر

سلام
من می خوام کد تهیه پشتیبان (Backup) گیری از اطلاعات دیتابیس رو با CommonDialog بنویسم
کسی هست که به من کمک کنه
ممنون

evilboy

دوشنبه 06 آذر 1385, 15:59 عصر

یعنی کسی بلد نیست :افسرده:

sjj

سه شنبه 07 آذر 1385, 01:35 صبح

با کد زیر من این کار رو تو برنامم انجام دادم

Private Sub Button1_Click()
On Error Resum Next
CDialog1.ShowSave
I = PathFileExistsA(CDialog1.FileName)
If I = 1 Then
K = MsgBox"فایل وجود دارد.آیا مایل به بازنویسی هستید ؟", vbYesNo + vbQuestion, "بازنویسی")
If K = 6 Then
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
Else
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
End Sub

اگه خواستید بگید تا برنامش رو هم بزارم.

MM_Mofidi

چهارشنبه 08 آذر 1385, 15:50 عصر

من از این کد برای compact and repair استفاده میکنم اگر فقط هدف گرفتن یک کپی ساده است خوب بفرمایید(Visual Basic Script file .VBS)

Set Dbe = CreateObject("DAO.DBEngine.36")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set WSHShell = CreateObject("WScript.Shell")
Const SW_SHOWMAXIMIZED = 3
ARGSNO=WScript.Arguments.COUNT
if ARGSNO > 0 then
DbName=WScript.Arguments.Item(I)
Else
WScript.Quit
End if
Pos = InStrRev(DbName, "\")
Na = Mid(DbName, Pos + 1)
Pa = Left(DbName, Pos)
FreeName = GetFreeName(Pa,Na)
On Error Resume Next
Do
Err.Clear
Dbe.CompactDatabase DbName ,Pa & FreeName
Loop While Err <> 0
On Error Goto 0
FSO.DeleteFile DbName ,True 'Delete the Source File
FSO.MoveFile Pa & FreeName,DbName 'Rename The DesFile 2 SrcFil
FSO.DeleteFile WScript.ScriptFullName 'Delete the Source Script
WSHShell.Run "%windir%\Explorer.exe " & DbName, SW_SHOWMAXIMIZED , False
Function GetFreeName(Directory , DefaultName )
if DefaultName="" then
DefaultName= "NewFile.Tmp"
End If
i = InStrRev(DefaultName, ".")
FileName = left(DefaultName,i-1)
Ext= Mid(DefaultName, i )
i=0
If (FSO.FolderExists(Directory)) Then
Do While fso.FileExists(Directory & FileName & EXT)
FileName = FileName & i
i = i + 1
Loop
Else
GetFreeName = vbNullString
End If
GetFreeName = FileName & EXT
End Function

اما تابعی که من استفاده میکنم

Dim TBLName As String, FN As String, SqlStr As String, Na As String, Pa As String
Dim ANS As Boolean
Dim Db As Database
Dim fso
On Error GoTo Compact_Click_Err_handler
FN = TXTFileName.Value
'FN = Right(FN, Len(FN) - InStrRev(FN, "\"))
TXTFileName.SetFocus
CloseForm.Enabled = False
Compact.Enabled = False
DoCmd.Hourglass True
'******************* Start Importing
'1-Creat File And Copy DAta to That
Label1.ForeColor = vbYellow
Set fso = CreateObject("Scripting.FileSystemObject")
If fso.FileExists(FN) Then Kill FN
Set Db = CreateDatabase(FN, dbLangGeneral)
Db.Close
ANS = Export_All_Tabels(FN, True, False, True)
If ANS Then
Label1.ForeColor = vbGreen
Else
Label1.ForeColor = vbRed
GoTo Compact_Click_Err_handler
End If
'2-Compact & repair DataBase
Label2.ForeColor = vbYellow
DoEvents
Pos = InStrRev(FN, "\")
Na = Mid(FN, Pos + 1)
Pa = Left(FN, Pos)
Na = GetFreeFileName(Pa, Left(Na, InStrRev(Na, ".")), "MDB")
DBEngine.CompactDatabase FN, Na
Kill FN
Label2.ForeColor = vbGreen
'3-Zip The Database File
Label3.ForeColor = vbYellow
DoEvents
Zip1.OutputFile = FN
Zip1.InputFile = Pa & Na
Zip1.Go
Kill Pa & Na
Label3.ForeColor = vbGreen
Restore_Orginals:
CloseForm.Enabled = True
If Len(TXTFileName.Value) > 0 Then Compact.Enabled = True
DoCmd.Hourglass False
Label1.ForeColor = 9868950
Label2.ForeColor = 9868950
Label3.ForeColor = 9868950
Exit Sub
Compact_Click_Err_handler:
If Err.Number = 0 Then
MsgBox "ÚãáíÇÊ ÈÇ ÎØÇ ãæÇÌå ÔÏ áØÝÇ ÏæÈÇÑå ÊáÇÔ ˜äíÏ." & _
vbCrLf & "ÏÑ ÕæÑÊ ãÔÇåÏå ãÊæÇáí Çíä íÇã ÈÇ ØÑÇÍ ÊãÇÓ ÈíÑíÏ" _
, vbCritical + vbMsgBoxRight + vbOKOnly, Space(60) & "ÈÑæÒ ÎØÇ åäÇã ÇíÍÇÏ ÔÊíÈÇä"
Else
ErrorControl Err.Number
End If
Resume Restore_Orginals

این تابع را هم که فراخوانی کردم

Function Export_All_Tabels(ByVal MDB_FileNamePath As String, _
Optional ByVal RelationSh As Boolean = True, _
Optional ByVal SystemTables As Boolean = False, _
Optional ByVal OverWriteAll As Boolean = True) As Boolean

On Error GoTo Export_All_Tabels_Err_Handler
'*************** Init ************
Export_All_Tabels = False
'*********************************
Dim Des_Name As String
Dim AllTableDefs As TableDefs
Dim MyDb As Database
Dim LErrAction As VBA.VbMsgBoxResult
Set MyDb = CurrentDb
Set AllTableDefs = MyDb.TableDefs

For i = 0 To AllTableDefs.Count - 1
ANS = vbNullString
If (AllTableDefs(i).Attributes = 0) Or SystemTables Then _
ANS = Export_To_External_Database(MDB_FileNamePath, AllTableDefs(i).Name, _
AllTableDefs(i).Name, acExport, acTable, OverWriteAll)
If Len(ANS) > 0 Then
Debug.Print AllTableDefs(i).Name & vbTab & "Exported Correctly as " & ANS
Else
Debug.Print "Some Error Accured on Exporting" & vbTab & AllTableDefs(i).Name
End If
Next
MyDb.Close
'If RelationSh Then Set MyDb.CreateRelation = CurrentDb.Relations
'For j = 0 To AllTableDefs.Count - 1
If RelationSh Then
Set MyDb = OpenDatabase(MDB_FileNamePath)
Dim rel As Relation
Dim L As Field
For i = 0 To CurrentDb.Relations.Count - 1
Set rel = MyDb.CreateRelation

rel.Name = CurrentDb.Relations(i).Name
rel.Table = CurrentDb.Relations(i).Table
rel.ForeignTable = CurrentDb.Relations(i).ForeignTable
rel.Attributes = CurrentDb.Relations(i).Attributes
For j = 0 To CurrentDb.Relations(i).Fields.Count - 1
Set L = rel.CreateField
L.Name = CurrentDb.Relations(i).Fields(j).Name
L.ForeignName = CurrentDb.Relations(i).Fields(j).ForeignName
rel.Fields.Append L
Next
MyDb.Relations.Append rel
Debug.Print "Crete relation from " & CurrentDb.Relations(i).Table & _
vbTab & "To " & CurrentDb.Relations(i).ForeignTable
Next
MyDb.Close
End If
If LErrAction <> vbIgnore Then Export_All_Tabels = True Else Export_All_Tabels = False
Exit Function
Export_All_Tabels_Err_Handler:
ANS = MsgBox(Err.Number & vbCrLf & Err.Description & vbCrLf & "Do you want to Try Again?" _
, vbCritical + vbAbortRetryIgnore)
Select Case ANS
Case vbRetry
LErrAction = vbRetry
Resume
Case vbIgnore
LErrAction = vbIgnore
Resume Next
Case vbAbort
LErrAction = vbAbort
Export_All_Tabels = vbNullString
Exit Function
Case Else
LErrAction = vbAbort
Export_All_Tabels = vbNullString
Exit Function
End Select
End Function

اینم اون یکیش

Function Export_To_External_Database _
(ByVal MDB_FileNamePath As String, ByVal SourceName As String, _
Optional ByVal DestenationName As String = "_ExportedTable_", _
Optional ByVal ExportType As Access.AcDataTransferType = acExport, _
Optional ByVal ObjectType As Access.AcObjectType = acTable, _
Optional Overwrite As Boolean = False) As String
On Error GoTo Export_To_External_Database_Err_Handler
Dim Des_Name As String
Dim AllTableDefs As TableDefs
Dim MyDb As Database
Dim LErrAction As VBA.VbMsgBoxResult
'*************** Init ************
Des_Name = DestenationName
Export_To_External_Database = vbNullString
Err.Clear
'*********************************
Func_Start:
Set MyDb = OpenDatabase(MDB_FileNamePath, True)
Set AllTableDefs = MyDb.TableDefs

If Not Overwrite Then
For i = 0 To AllTableDefs.Count - 1
If Des_Name = AllTableDefs(i).Name Then
'***** if you prefer retry use these
ANS = MsgBox("The Tabel You Select Is Currently Exist Do You Want To OverWrite It?", _
vbExclamation + vbYesNoCancel, "Remeving Some Object")
If ANS = vbNo Then
Des_Name = InputBox("Enter The Table Name", "Choose Destenation Tabel Name")
GoTo Func_Start
Else: If ANS = vbCancel Then Exit Function
End If
'***********************************
End If
Next
End If
If Des_Name = "_ExportedTable_" Then Des_Name = Des_Name & File_Name
MyDb.Close
DoCmd.TransferDatabase ExportType, "Microsoft Access", _
MDB_FileNamePath, ObjectType, SourceName, Des_Name

' if no Error accrued return the Table Name
If LErrAction <> vbIgnore Then Export_To_External_Database = Des_Name
Exit Function
Export_To_External_Database_Err_Handler:
ANS = MsgBox(Err.Number & vbCrLf & Err.Description & vbCrLf & "Do you want to Try Again?" _
, vbCritical + vbAbortRetryIgnore)
Select Case ANS
Case vbRetry
LErrAction = vbRetry
Resume
Case vbIgnore
LErrAction = vbIgnore
Resume Next
Case vbAbort
LErrAction = vbAbort
Export_To_External_Database = vbNullString
Exit Function
Case Else
LErrAction = vbAbort
Export_To_External_Database = vbNullString
Exit Function
End Select
End Function

--------------------
اااااااااااااا چقد زیاد شد. خوب امیدوارم بدرد بخوره مشکل داشتید بگید شاید بلد بودم جواب دادم.
ضمنا من کپی و پیست کردم اگر غلط غلوط داره بگید :)

evilboy

چهارشنبه 08 آذر 1385, 16:02 عصر

دوست عزیز ممنون
ولی کدی که من با کمک کد Sjj نوشتم تقریبا 5 تا 6 خط بیشتر نیست
در هر صورت ممنون

mortez maya

چهارشنبه 08 آذر 1385, 22:17 عصر

دوست عزیز ممنون
ولی کدی که من با کمک کد Sjj نوشتم تقریبا 5 تا 6 خط بیشتر نیست
در هر صورت ممنون

بله کد sjj واقعا کمتره من هم همیشه از همین کد استفاده می کنم./

sjj

یک شنبه 12 آذر 1385, 06:46 صبح

خواهش میکنم.قابل شما رو نداشت.

MM_Mofidi

یک شنبه 19 آذر 1385, 08:35 صبح

دیدی نگرفتی چی شد؟
گفتم compact & repair اونم از داخل برنامه در حال اجرا خودت.
خوب به هر حال منطقی ترین کار استفاده تز کوتاه ترین و مطمئن ترین کدی است که
کار آدم راه بندازه

evilboy

دوشنبه 20 آذر 1385, 17:02 عصر

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

Dim v As String
Dim n As New FileSystemObject
CommonDialog1.ShowSave
v = CommonDialog1.FileName
Text1.Text = v
If v = "" Then
MsgBox "لطفا مسیر فایل پشتیبان را مشخص کنید", vbCritical, "عدم انتخاب مسیر"
Else
Call n.CopyFile(App.Path & "/Kol.mdb", v)
End If

Mahsa Hatefi

چهارشنبه 13 دی 1385, 09:58 صبح

با کد زیر من این کار رو تو برنامم انجام دادم

Private Sub Button1_Click()
On Error Resum Next
CDialog1.ShowSave
I = PathFileExistsA(CDialog1.FileName)
If I = 1 Then
K = MsgBox"فایل وجود دارد.آیا مایل به بازنویسی هستید ؟", vbYesNo + vbQuestion, "بازنویسی")
If K = 6 Then
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
Else
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
End Sub

اگه خواستید بگید تا برنامش رو هم بزارم.

استاد گرامی
فرض بگیریم از بعضی از جداول mdb می خواهیم ذخیره بگیریم به عنوان پشتوانه اطلاعات .
من ابتدا جداولم را به تکست تبدیل و سپس zip میکنم تا فضای کمی اشغال کند . آیا کد شما همین کار را می کند یا از کل mdb\mde ذخیره میگیرد ؟
در ضمن به نظر دوستان بهترین کار کدام است ؟ در صورت امکان نمونه ای که اطلاعات را هم زیپ کند لطف کنید ممنون می شویم

evilboy

چهارشنبه 13 دی 1385, 20:52 عصر

دوست عزیز این کد زیپ نمی کنه
مستقیم از MDB پشتیبان می گیره

piter1355

چهارشنبه 13 دی 1385, 23:25 عصر

برای کامپکت اند ریپیر کردن باید اول دیتابیستو ببندی .

nima_9m

چهارشنبه 18 شهریور 1388, 12:55 عصر

با کد زیر من این کار رو تو برنامم انجام دادم

Private Sub Button1_Click()
On Error Resum Next
CDialog1.ShowSave
I = PathFileExistsA(CDialog1.FileName)
If I = 1 Then
K = MsgBox"فایل وجود دارد.آیا مایل به بازنویسی هستید ؟", vbYesNo + vbQuestion, "بازنویسی")
If K = 6 Then
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
Else
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
End Sub

اگه خواستید بگید تا برنامش رو هم بزارم.
اگه میشه برنامش و هم بذارید ممنون

nima_9m

چهارشنبه 18 شهریور 1388, 14:29 عصر

با کد زیر من این کار رو تو برنامم انجام دادم

Private Sub Button1_Click()
On Error Resum Next
CDialog1.ShowSave
I = PathFileExistsA(CDialog1.FileName)
If I = 1 Then
K = MsgBox"فایل وجود دارد.آیا مایل به بازنویسی هستید ؟", vbYesNo + vbQuestion, "بازنویسی")
If K = 6 Then
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
Else
Call CopyFileA(App.Path + "\Data\VideoClub.mdb", CDialog1.FileName, 0)
End If
End Sub

اگه خواستید بگید تا برنامش رو هم بزارم.
لطفا برنامش و هم بذارید