MTNQ > 03-04-15, 03:13 AM
(31-03-15, 01:12 PM)cpucloi Đã viết: Không phải là không quan tâm, bởi vì mình chưa có nhu cầu Backup Database thôi mà, vẫn theo dõi bài của MatTroiNguQuen đều đấy chứ.
P/s: Dạo này cũng hơi bận, chỉ thỉnh thoảng vô 4rum thôi.
(02-04-15, 10:20 AM)chuvoicon Đã viết: Cảm ơn bác MatTroiNguQuen...
maidinhdan > 03-04-15, 09:40 AM
(31-03-15, 02:04 AM)MatTroiNguQuen Đã viết: -Nếu có thời gian thì bài viết sau mình sẽ giới thiệu tiếp về FileSystem Object, bổ sung thêm một số tùy chọn:
+ Sao chép đồng thời Compact
+ Sao chép và nén với định dạng RAR, ZIP có đặt password (dĩ nhiên là sẽ có hàm giải nén và phụ hồi CSDL)
Xuân Thanh > 03-04-15, 10:33 AM
MTNQ > 01-06-15, 03:47 AM
(03-04-15, 09:40 AM)maidinhdan Đã viết: Em thích nhất Call file Backup lên để Compact thôi....Bởi khi link table và copy để lưu backup thì Data Backup đó nó phìn to thiệt...
Function CompactDB(strSourceFile As String, Optional strPWD As String, Optional blnBackupSource As Boolean, _
Optional strBackupFile As String, Optional ByRef strMSG As String) As String
On Error GoTo Err_handler
Dim strCompactFile As String
Dim MyArr As Variant
Dim i As Integer
Dim objEngine As DAO.DBEngine
If FileIsLocked(strSourceFile) Then Exit Function
Set objEngine = Application.DBEngine
MyArr = ParseFileName(strSourceFile)
DoCmd.Hourglass True
If blnBackupSource Then
If strBackupFile = "" Then
strBackupFile = BuildBackupFileName(strSourceFile)
End If
If BackupDB(strSourceFile, strBackupFile) = False Then
strMSG = strMSG & vbCrLf & "-Qua trinh lam gon CSDL khong thanh cong! "
GoTo Err_Exit
End If
End If
strCompactFile = MyArr(1) & MyArr(2) & "_COMPACTED" & MyArr(3)
If FileSysObj("FileExists", strCompactFile) Then
FileSysObj "DeleteFile", strCompactFile
End If
Compact:
DoCmd.Hourglass True
' Compact CSDL va xuat sang mot tap tin moi (strCompactFile).
If strPWD <> "" Then
objEngine.CompactDatabase strSourceFile, strCompactFile, , , ";pwd=" & strPWD
Else
objEngine.CompactDatabase strSourceFile, strCompactFile
End If
'Neu khong co loi, tuc la qua trinh CompactDatabase hoan thanh thi xoa CSDL hien hanh
FileSysObj "DeleteFile", strSourceFile
'Sua ten file da Compact thanh CSDL hien hanh
If Not FileSysObj("MoveFile", strCompactFile, strSourceFile) Then GoTo Err_Exit
'Thong bao da hoan tat qua trinh CompactDatabase
strMSG = strMSG & vbCrLf & "-Lam gon CSDL thanh cong! "
Err_Exit:
DoCmd.Hourglass False
Set objEngine = Nothing
Exit Function
Err_handler:
DoCmd.Hourglass False
If Err.Number = 3031 Then
i = i + 1
If i > 1 And i < 4 Then MsgBox "Mat khau khong dung!"
If i > 3 Then
strMSG = strMSG & vbCrLf & "-Qua trinh lam gon CSDL khong thanh cong! "
Resume Err_Exit
End If
strPWD = GetPassWord("Vui long cho biet mat khau cua CSDL:", 4 - i)
If strPWD = "" Then i = 4
Resume Compact
Else
MsgBox Err.Description, vbExclamation, "CompactDB Error: " & Err.Number
strMSG = strMSG & vbCrLf & "-Qua trinh lam gon CSDL khong thanh cong! "
End If
Resume Err_Exit
End Function
Public Function GetPassWord(Optional Message As String, Optional ingCount As Integer) As String
Dim strTitle As String, Default As String, MyValue As Variant
strTitle = "Nhap Mat Khau"
If ingCount <> 0 Then
Message = Message & vbCrLf & "(Ban con " & ingCount & " lan nhap mat khau!)"
End If
Default = "123456"
MyValue = InputBox(Message, strTitle, Default)
GetPassWord = MyValue
End Function
Public Function ParseFileName(strPath As String, Optional iRet As Long = -1) As Variant
On Error GoTo Err_handler
Dim strDrive As String
Dim strFolderPath As String
Dim strFullName As String
Dim strShortName As String
Dim strFileExt As String
Dim strElse As String
If strPath = "" Then Exit Function
strDrive = Left$(strPath, InStr(strPath, ":") + 1)
strFolderPath = Left$(strPath, InStrRev(strPath, "\"))
strFullName = Mid$(strPath, Len(strFolderPath) + 1)
If InStrRev(strFullName, ".") > 1 Then
strShortName = Left$(strFullName, InStrRev(strFullName, ".") - 1)
End If
strFileExt = Mid$(strFullName, Len(strShortName) + 1)
strElse = strFolderPath & strShortName
Select Case iRet
Case -1
ParseFileName = Array(strDrive, strFolderPath, strShortName, strFileExt, strFullName, strElse)
Case 0
ParseFileName = strDrive
Case 1
ParseFileName = strFolderPath
Case 2
ParseFileName = strShortName
Case 3
ParseFileName = strFileExt
Case 4
ParseFileName = strFullName
Case 5
ParseFileName = strElse
End Select
Err_Exit:
Exit Function
Err_handler:
ParseFileName = ""
MsgBox Err.Description, , "ParseFileName Err: " & Err.Number
Resume Err_Exit
End Function
chuvoicon > 03-06-15, 12:53 PM
MTNQ > 09-06-15, 02:40 AM
MTNQ > 09-06-15, 03:39 AM
Public Sub OpenDB(strDbName As String, Optional strPWD As String, Optional blnVisible As Boolean)
On Error GoTo Err_OpenDB
Dim appAccess As Object
Dim strMyPath As String
strMyPath = CurrentDb.Name
If strDbName = "" Then
Exit Sub
End If
If Dir$(strDbName) = "" Then
MsgBox "Khong tim thay tap tin theo duong dan: " & vbCrLf & strDbName
Exit Sub
End If
Set appAccess = CreateObject("Access.Application")
If appAccess.SysCmd(7) >= 10 Then
appAccess.AutomationSecurity = 1
End If
appAccess.OpenCurrentDatabase strDbName, False, strPWD
appAccess.Run "CallBackup", strMyPath, blnVisible
appAccess.Visible = blnVisible
Exit_OpenDB:
Set appAccess = Nothing
Exit Sub
Err_OpenDB:
If Err.Number <> 0 Then MsgBox Err.Description, , "OpenDB Error: " & Err.Number
Resume Exit_OpenDB
End Sub
If appAccess.SysCmd(7) >= 10 Then
appAccess.AutomationSecurity = 1
End If
MTNQ > 02-07-15, 09:25 PM
MTNQ > 03-07-15, 12:33 AM
thanhtruong > 06-08-16, 08:34 PM