Резервная копия - Microsoft Office Access

smoky · 12.04.2011, 23:04

Озадачился созданием сабжа. Рассмотрим пример: есть сервер win с расшаренной папкой с правами на определенного юзер/логин; хотелось бы передать файл БД по локалке. Как просто сохранить файл на диске - проблем вроде не возникает. А вот как сохранить в запароленную папку, да еще и программно? интуитивно предполагаю что тут надо связку WinAPI и VBA рассматривать. Погуглив, практически ничего не нашел, кроме как пространных намеков на эту связку. Может у общественности есть какие соображения на этот счет?

smoky · 17.04.2011, 16:12

Продвинулся в изучении данного вопроса но не далеко...

Код:

    Public Declare PtrSafe Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUsername As String, ByVal dwFlags As LongPtr) As Long
    Public Declare PtrSafe Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As LongPtr, ByVal fForce As LongPtr) As Long

Данный код вываливается в ошибку Compile-error:User-Defined type not defined

Вот весь код который в модуле:

Код:

    Public Declare PtrSafe Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUsername As String, ByVal dwFlags As LongPtr) As Long
    Public Declare PtrSafe Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As LongPtr, ByVal fForce As LongPtr) As Long

Private Sub Form_Load()
Option Explicit

Public ErrorNum As Long
Public ErrorMsg As String
Public rc As Long
Public RemoteName As String

Public Const ERROR_BAD_DEV_TYPE = 66&
Public Const ERROR_ALREADY_ASSIGNED = 85&
Public Const ERROR_ACCESS_DENIED = 5&
Public Const ERROR_BAD_NET_NAME = 67&
Public Const ERROR_BAD_PROFILE = 1206&
Public Const ERROR_BAD_PROVIDER = 1204&
Public Const ERROR_BUSY = 170&
Public Const ERROR_CANCEL_VIOLATION = 173&
Public Const ERROR_CANNOT_OPEN_PROFILE = 1205&
Public Const ERROR_DEVICE_ALREADY_REMEMBERED = 1202&
Public Const ERROR_EXTENDED_ERROR = 1208&
Public Const ERROR_INVALID_PASSWORD = 86&
Public Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Public Const ERROR_NO_NETWORK = 1222&
Public Const ERROR_NO_CONNECTION = 8
Public Const ERROR_NO_DISCONNECT = 9
Public Const ERROR_DEVICE_IN_USE = 2404&
Public Const ERROR_NOT_CONNECTED = 2250&
Public Const ERROR_OPEN_FILES = 2401&
Public Const ERROR_MORE_DATA = 234

Public Const CONNECT_UPDATE_PROFILE = &H1
Public Const RESOURCETYPE_DISK = &H1

Public Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type

Public lpNetResourse As NETRESOURCE

Public Sub Connect(ByVal HostName As String, ByVal RemoteName As String, ByVal Username As String, ByVal Password As String)
Dim lpUsername As String
Dim lpPassword As String
On Error GoTo Err_Connect
ErrorNum = 0
ErrorMsg = ""
lpNetResourse.dwType = RESOURCETYPE_DISK
lpNetResourse.lpLocalName = RemoteName & Chr(0)
'Drive Letter to use
lpNetResourse.lpRemoteName = "\\" & HostName & Chr(0)
'Network Path to share
lpNetResourse.lpProvider = Chr(0)
lpPassword = Password & Chr(0)
'password on share pass "" if none
lpUsername = Username & Chr(0)
'username to connect as if applicable
rc = WNetAddConnection2(lpNetResourse, lpPassword, lpUsername, CONNECT_UPDATE_PROFILE)
If rc <> 0 Then GoTo Err_Connect
Exit Sub
Err_Connect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Public Sub DisConnect(ByVal Name As String, ByVal ForceOff As Boolean)
On Error GoTo Err_DisConnect
ErrorNum = 0
ErrorMsg = ""
rc = WNetCancelConnection2(Name & Chr(0), CONNECT_UPDATE_PROFILE, ForceOff)
If rc <> 0 Then GoTo Err_DisConnect
Exit Sub
Err_DisConnect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Private Function WnetError(Errcode As Long) As String
Select Case Errcode
Case ERROR_BAD_DEV_TYPE
WnetError = "Bad device."
Case ERROR_ALREADY_ASSIGNED
WnetError = "Already Assigned."
Case ERROR_ACCESS_DENIED
WnetError = "Access Denied."
Case ERROR_BAD_NET_NAME
WnetError = "Bad net name"
Case ERROR_BAD_PROFILE
WnetError = "Bad Profile"
Case ERROR_BAD_PROVIDER
WnetError = "Bad Provider"
Case ERROR_BUSY
WnetError = "Busy"
Case ERROR_CANCEL_VIOLATION
WnetError = "Cancel Violation"
Case ERROR_CANNOT_OPEN_PROFILE
WnetError = "Cannot Open Profile"
Case ERROR_DEVICE_ALREADY_REMEMBERED
WnetError = "Device already remembered"
Case ERROR_EXTENDED_ERROR
WnetError = "Device already remembered"
Case ERROR_INVALID_PASSWORD
WnetError = "Invalid Password"
Case ERROR_NO_NET_OR_BAD_PATH
WnetError = "Could not find the specified device"
Case ERROR_NO_NETWORK
WnetError = "No Network Present"
Case ERROR_DEVICE_IN_USE
WnetError = "Connection Currently in use "
Case ERROR_NOT_CONNECTED
WnetError = "No Connection Present"
Case ERROR_OPEN_FILES
WnetError = "Files open and the force parameter is false"
Case ERROR_MORE_DATA
WnetError = "Buffer to small to hold network name, make lpnLength bigger"
Case Else:
WnetError = "Unrecognized Error " + Str(Errcode) + "."
End Select
End Function
End Function

Код нашел, проверить в win32 не имеется возможным... поэтому пытаюсь win64. OC Win7x64 (MSA 2010x64)

smoky · 17.04.2011, 16:19

На форме две кнопки на вкл и выкл сетевого диска:

Код:

Private Sub 1_Click()
Call Module1.Connect("smoky\c$", "K:", "defaultsharename", "passw")
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox Module1.ErrorMsg
End If
End Sub
Private Sub 2_Click()
Call Module1.DisConnect("K:", True)
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
MsgBox Module1.ErrorMsg
End If
End Sub

smoky · 17.04.2011, 21:58

Две кнопки с событиями на форме:

Код:

Option Explicit
Private Sub btnConnect_Click()

Call Module1.Connect("path", "R:", "login", "passw")
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
    MsgBox Module1.ErrorMsg
End If
End Sub


Private Sub btnDisConnect_Click()
Call Module1.DisConnect("R:", True)
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
    MsgBox Module1.ErrorMsg
End If
End Sub

Модуль:

Код:

Option Explicit
Public Declare PtrSafe Function WNetAddConnection2 Lib "mpr.dll" Alias "WNetAddConnection2A" (lpNetResource As NETRESOURCE, ByVal lpPassword As String, ByVal lpUsername As String, ByVal dwFlags As LongPtr) As Long
Public Declare PtrSafe Function WNetCancelConnection2 Lib "mpr.dll" Alias "WNetCancelConnection2A" (ByVal lpName As String, ByVal dwFlags As LongPtr, ByVal fForce As LongPtr) As Long

Public ErrorNum As Long
Public ErrorMsg As String
Public rc As Long
Public RemoteName As String

Public Const ERROR_BAD_DEV_TYPE = 66&
Public Const ERROR_ALREADY_ASSIGNED = 85&
Public Const ERROR_ACCESS_DENIED = 5&
Public Const ERROR_BAD_NET_NAME = 67&
Public Const ERROR_BAD_PROFILE = 1206&
Public Const ERROR_BAD_PROVIDER = 1204&
Public Const ERROR_BUSY = 170&
Public Const ERROR_CANCEL_VIOLATION = 173&
Public Const ERROR_CANNOT_OPEN_PROFILE = 1205&
Public Const ERROR_DEVICE_ALREADY_REMEMBERED = 1202&
Public Const ERROR_EXTENDED_ERROR = 1208&
Public Const ERROR_INVALID_PASSWORD = 86&
Public Const ERROR_NO_NET_OR_BAD_PATH = 1203&
Public Const ERROR_NO_NETWORK = 1222&
Public Const ERROR_NO_CONNECTION = 8
Public Const ERROR_NO_DISCONNECT = 9
Public Const ERROR_DEVICE_IN_USE = 2404&
Public Const ERROR_NOT_CONNECTED = 2250&
Public Const ERROR_OPEN_FILES = 2401&
Public Const ERROR_MORE_DATA = 234

Public Const CONNECT_UPDATE_PROFILE = &H1
Public Const RESOURCETYPE_DISK = &H1

Public Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As String
lpRemoteName As String
lpComment As String
lpProvider As String
End Type

Public lpNetResourse As NETRESOURCE

Public Sub Connect(ByVal HostName As String, ByVal RemoteName As String, ByVal Username As String, ByVal Password As String)
Dim lpUsername As String
Dim lpPassword As String
On Error GoTo Err_Connect
ErrorNum = 0
ErrorMsg = ""
lpNetResourse.dwType = RESOURCETYPE_DISK
lpNetResourse.lpLocalName = RemoteName & Chr(0)
'Drive Letter to use
lpNetResourse.lpRemoteName = "\\" & HostName & Chr(0)
'Network Path to share
lpNetResourse.lpProvider = Chr(0)
lpPassword = Password & Chr(0)
'password on share pass "" if none
lpUsername = Username & Chr(0)
'username to connect as if applicable
rc = WNetAddConnection2(lpNetResourse, lpPassword, lpUsername, CONNECT_UPDATE_PROFILE)
If rc <> 0 Then GoTo Err_Connect
Exit Sub
Err_Connect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Public Sub DisConnect(ByVal Name As String, ByVal ForceOff As Boolean)
On Error GoTo Err_DisConnect
ErrorNum = 0
ErrorMsg = ""
rc = WNetCancelConnection2(Name & Chr(0), CONNECT_UPDATE_PROFILE, ForceOff)
If rc <> 0 Then GoTo Err_DisConnect
Exit Sub
Err_DisConnect:
ErrorNum = rc
ErrorMsg = WnetError(rc)
End Sub

Private Function WnetError(Errcode As Long) As String
Select Case Errcode
Case ERROR_BAD_DEV_TYPE
WnetError = "Bad device."
Case ERROR_ALREADY_ASSIGNED
WnetError = "Already Assigned."
Case ERROR_ACCESS_DENIED
WnetError = "Access Denied."
Case ERROR_BAD_NET_NAME
WnetError = "Bad net name"
Case ERROR_BAD_PROFILE
WnetError = "Bad Profile"
Case ERROR_BAD_PROVIDER
WnetError = "Bad Provider"
Case ERROR_BUSY
WnetError = "Busy"
Case ERROR_CANCEL_VIOLATION
WnetError = "Cancel Violation"
Case ERROR_CANNOT_OPEN_PROFILE
WnetError = "Cannot Open Profile"
Case ERROR_DEVICE_ALREADY_REMEMBERED
WnetError = "Device already remembered"
Case ERROR_EXTENDED_ERROR
WnetError = "Device already remembered"
Case ERROR_INVALID_PASSWORD
WnetError = "Invalid Password"
Case ERROR_NO_NET_OR_BAD_PATH
WnetError = "Could not find the specified device"
Case ERROR_NO_NETWORK
WnetError = "No Network Present"
Case ERROR_DEVICE_IN_USE
WnetError = "Connection Currently in use "
Case ERROR_NOT_CONNECTED
WnetError = "No Connection Present"
Case ERROR_OPEN_FILES
WnetError = "Files open and the force parameter is false"
Case ERROR_MORE_DATA
WnetError = "Buffer to small to hold network name, make lpnLength bigger"
Case Else:
WnetError = "Unrecognized Error " + Str(Errcode) + "."
End Select
End Function

Осталось только прописать сохранение на диск смонтированный, и выкинуть обе кнопки, повесить все на одну большую SAVE )

smoky · 02.05.2011, 22:04

Несколько домучил код и получил вот такое:

Код:

Private Sub btn_connect_Click()

Dim strAppPath, server, login, pass, location, filename, filenamenoext, area, strSource, strDestination As String
Dim idProg, hProcess As Long
Dim blnOverwriteFiles As Boolean

'Настройки
server = "путь до папки на сервере"
login = Me.fld_login 'поле на форме
pass = Me.fld_password 'поле на форме
location = "R:\backup\"
strAppPath = Application.CurrentProject.Path & "\"
filename = Right(Application.CurrentDb.Name, Len(Application.CurrentDb.Name) - InStrRev(Application.CurrentDb.Name, "\"))
filenamenoext = Left(filename, InStr(filename, ".") - 1)
strSource = strAppPath + filename
strDestination = location & filename
blnOverwriteFiles = True
'Проверка нахождения файла на сервере (подключен ли диск)
Call Module1.Connect(server, "R:", login, pass)
If (Module1.rc <> 0) And (Module1.rc <> 85) Then
    MsgBox Module1.ErrorMsg
End If
If Dir(location & filename) <> "" _
    Then
        'Проверка использования файла БД на сервере
        If Dir(location & filenamenoext & ".laccbd") = "" _
            Then
                Call Module1.DisConnect("R:", True)
                If (Module1.rc <> 0) And (Module1.rc <> 85) Then
                    MsgBox Module1.ErrorMsg
                End If
            Else: If MsgBox("Подключение нарушено", vbExclamation) = vbOK Then Exit Sub
        End If
        If MsgBox("Вы запустили обновление базы данных." & vbCrLf & _
                "Процесс обновления может занять неопределенное время." & vbCrLf & _
                "Дождитесь окончания выполнения обновления." & vbCrLf & vbCrLf & _
                "Хотите продолжить?", vbInformation + vbYesNo, _
                "Обновление базы данных") = vbYes _
                Then
                    'Подключаем диск
                    Call Module1.Connect(server, "R:", login, pass)
                    If (Module1.rc <> 0) And (Module1.rc <> 85) Then
                        MsgBox Module1.ErrorMsg
                    End If
                    'Копируем данную БД на сервер
                    Dim objFSO As Object
                    Set objFSO = CreateObject("Scripting.FileSystemObject")
                    objFSO.CopyFile strSource, strDestination, blnOverwriteFiles
                    Set objFSO = Nothing
                    'Архивируем старую версию БД, отслеживая отработку архиватора
                    hProcess = OpenProcess(SYNCHRONIZE, 0, Shell(location & "zip\7za.exe a -tzip " & location & filenamenoext & Format(Date, "_YYYY-mm-dd_") & Format(Time, "_HH-MM") & ".zip " & location & filename, 0))
                    WaitForSingleObject hProcess, INFINITE
                    CloseHandle hProcess
                    'Отключаем диск
                    Call Module1.DisConnect("R:", True)
                    If (Module1.rc <> 0) And (Module1.rc <> 85) Then
                        MsgBox Module1.ErrorMsg
                    End If
                    MsgBox "База данных успешно обновлена." , vbInformation, "Обновление базы данных"
        End If
    Else: If MsgBox("Подключение нарушено", vbExclamation) = vbOK Then Exit Sub
End If
End Sub

Как видим происходит следующее:
1. Проверяется существующее подключение и нахождение файла предыдущего бэкапа на сервере и вероятность использования этого файла на сервере
2. Производится архивация текущего файла БД (для этого был положен в папку с бэкапом \zip\7za.exe - специальная версия архиватора 7zip) прямо в папку с бэкапами, программа дожидается отработки данного процесса блокируя все действия в БД
3. Копируется исходный файл БД на сервер (ну это надо было чисто мне для других целей)

Вот как то так. Поругайте код, может быть его можно как то упростить или может какие замечания будут. Код 100% работает.

12.04.2011, 23:04	#1
smoky Пользователь Подтвердите свой е-майл Регистрация: 13.05.2008 Сообщений: 65	Резервная копия Озадачился созданием сабжа. Рассмотрим пример: есть сервер win с расшаренной папкой с правами на определенного юзер/логин; хотелось бы передать файл БД по локалке. Как просто сохранить файл на диске - проблем вроде не возникает. А вот как сохранить в запароленную папку, да еще и программно? интуитивно предполагаю что тут надо связку WinAPI и VBA рассматривать. Погуглив, практически ничего не нашел, кроме как пространных намеков на эту связку. Может у общественности есть какие соображения на этот счет?

Похожие темы
Тема	Автор	Раздел	Ответов	Последнее сообщение
Скрытая копия	smrtipathaka	Microsoft Office Excel	0	04.04.2011 11:07
Копия массива	Максикок	Помощь студентам	1	15.03.2011 13:05
Резервная копия БД	Binturong	Microsoft Office Access	6	23.10.2010 19:59
Копия файла	program123	Общие вопросы Delphi	9	26.02.2010 18:22
Кто печатает деньги? - Федеральная резервная система (США)	Alar	Свободное общение	0	22.04.2008 22:33