اخواني عندي برنامج على شبكة وتم تقسيم البرنامج جزء خاص بالنماذج والتقارير والجزء الاخر خاص بالجداول
استخدمت دالة النسخ الاحتياطي لعمل نسخة طبق الاصل من البرنامج
وبها تم نسخ الجزء الذي يحتوي على النماذج والتقارير فقط ولم يتم نسخ الجزء المهم وهو الخاص الجداول
فارجو مساعدتي في تعديل كود الدالة او دالة جديدة تمكن مستخدم البرنامج من نسخ الجزء المحتوي على 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
فارجو من اخواننا المشرفين والاعضاء مساعدتي وله مني خالص الدعاء
