رجاء المساعدة في كود النسخ الاحتياطي

[taha2002]

اخواني عندي برنامج على شبكة وتم تقسيم البرنامج جزء خاص بالنماذج والتقارير والجزء الاخر خاص بالجداول

استخدمت دالة النسخ الاحتياطي لعمل نسخة طبق الاصل من البرنامج

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

فارجو مساعدتي في تعديل كود الدالة او دالة جديدة تمكن مستخدم البرنامج من نسخ الجزء المحتوي على data الجداول

هذا هو محتوى الدالة

Function fMakeBackup() As Boolean

Dim strMsg As String

Dim tshFileOp As SHFILEOPSTRUCT

Dim lngRet As Long

Dim strSaveFile As String

Dim lngFlags As Long

Dim FolderToCopy

Const cERR_USER_CANCEL = vbObjectError + 1

Const cERR_DB_EXCLUSIVE = vbObjectError + 2

On Local Error GoTo fMakeBackup_Err

If fDBExclusive = True Then err.Raise cERR_DB_EXCLUSIVE

strMsg = "åá ÊÑíÏ Úãá äÓÎÉ ÅÍÊíÇØíÉ áåÐÇ ÇáÈÑäÇãÌ ¿"

If MsgBox(strMsg, vbQuestion + vbYesNo + vbMsgBoxRight + _

vbMsgBoxRtlReading, "ÊÃßíÏ ÇáäÓÎ") = vbNo Then _

err.Raise cERR_USER_CANCEL

lngFlags = FOF_SIMPLEPROGRESS Or _

FOF_FILESONLY Or _

FOF_RENAMEONCOLLISION

strSaveFile = CurrentDb.NAME

With tshFileOp

.wFunc = FO_COPY

.hwnd = hWndAccessApp

.pFrom = CurrentDb.NAME & vbNullChar

FolderToCopy = BrowseForFolder

If Len(FolderToCopy & "") = 1 Then

Exit Function

Else

.pTo = FolderToCopy

End If

.fFlags = lngFlags

End With

lngRet = apiSHFileOperation(tshFileOp)

fMakeBackup = (lngRet = 0)

fMakeBackup_End:

Exit Function

fMakeBackup_Err:

fMakeBackup = False

Select Case err.Number

Case cERR_USER_CANCEL:

'do nothing

Case cERR_DB_EXCLUSIVE:

MsgBox "The current database " & vbCrLf & CurrentDb.NAME & vbCrLf & _

vbCrLf & "is opened exclusively. Please reopen in shared mode" & _

" and try again.", vbCritical + vbOKOnly, "Database copy failed"

Case Else:

strMsg = "Error Information..." & vbCrLf & vbCrLf

strMsg = strMsg & "Function: fMakeBackup" & vbCrLf

strMsg = strMsg & "Description: " & err.Description & vbCrLf

strMsg = strMsg & "Error #: " & Format$(err.Number) & vbCrLf

MsgBox strMsg, vbInformation, "fMakeBackup"

End Select

Resume fMakeBackup_End

End Function

Private Function fCurrentDBDir() As String

Dim strDBPath As String

Dim strDBFile As String

strDBPath = CurrentDb.NAME

strDBFile = Dir(strDBPath)

fCurrentDBDir = Left(strDBPath, InStr(strDBPath, strDBFile) - 1)

End Function

Function fDBExclusive() As Integer

Dim hFile As Integer

hFile = FreeFile

On Error Resume Next

Select Case err

Case 0

fDBExclusive = False

Case 70

fDBExclusive = True

Case Else

fDBExclusive = err

End Select

Close hFile

On Error GoTo 0

End Function

Private Sub ÃãÑ0_Click()

Call fMakeBackup

End Sub

Private Function BrowseForFolder()

Dim bi As BROWSEINFO

Dim IDL As ITEMIDLIST

Dim pidl As Long

Dim r As Long

Dim pos As Integer

Dim spath As String

Dim lblSelected As String

bi.pidlRoot = 0&

bi.lpszTitle = "ÍÏÏ æÌåÉ ÇáäÓÎÉ ÇáÃÍÊíÇØíÉ :"

bi.ulFlags = BIF_RETURNONLYFSDIRS

pidl& = SHBrowseForFolder(bi)

spath$ = Space$(512)

r = SHGetPathFromIDList(ByVal pidl&, ByVal spath$)

If r Then

pos = InStr(spath$, Chr$(0))

'pos = spath

lblSelected = Left(spath$, pos - 0)

Else: lblSelected = ""

End If

BrowseForFolder = lblSelected & "\"

End Function

فارجو من اخواننا المشرفين والاعضاء مساعدتي وله مني خالص الدعاء

[rudwan]

اطلع على هذه المشاركة و حمل منها الملف و هو يعطيك امكانية نسخ أكثر من قاعدة بيانات و وفق جدول زمني مبرمج ( أي يومي تلقائي )

http://www.officena.net/ib/index.php?showt...indpost&p=49278

[taha2002]

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