Процедура архивирования экспортируемого файла из Access в Excel/Word etc.
Sub SaveCopy()
Dim Wb As Workbook
Dim wbName, Today, WinRarApp$, iPath$, iFileName$, iFileNameRar$, Adr, RetVal
'каждый день сохраняет копию файла со вчерашней датой, производит архивацию этой копии и удаляет файл *.xls, оставляя только архив *.rar
On Error GoTo ErrorHandler
If MsgBox("Сохранить резервную копию файла?", vbOKCancel + vbQuestion, "Архив") = vbCancel Then Exit Sub
Set Wb = ActiveWorkbook
wbName = Wb.Name
Today = Format(CStr(Date), "yyyy/mm/dd")
iPath$ = "\"
iFileName$ = Left(wbName, Len(wbName) - 4) + "_" + Today + ".xls"
'Путь и название архива
iFileNameRar$ = iPath$ + Left(iFileName$, Len(iFileName$) - 3) + "rar"
'для проверки существования такого же файла
If Dir(iPath$ + iFileName$) <> "" Or Dir(iFileNameRar$) <> "" Then
MsgBox "Копия файла c датой " & Today & " в директории " & Chr(13) & iPath$ & " уже существует!", vbExclamation
Exit Sub
End If
'сохранение копии файла с добавлением вчерашней даты
Wb.SaveCopyAs (iPath$ + iFileName$)
iFileName$ = iPath$ + iFileName$
WinRarApp$ = "C:\Program Files\WinRAR\WinRAR.exe a -ep -df " '- ep -исключить пути из имён; -df - удалить файлы после архивации
Adr = WinRarApp$ & " """ & iFileNameRar$ & """ """ & iFileName$ & """ " 'добавляем кавычки, чтобы можно было было иметь пробелы в названии файла
RetVal = Shell(Adr, vbHide)
MsgBox "Копия файла c датой " & Today & " сохранена и заархивирована!" & Chr(13) & "По адресу: " & iPath$, vbInformation, "Архивация данных"
Exit Sub
ErrorHandler:
MsgBox "При сохранении копии файла произошла ошибка!" & vbCrLf & "Описание: " & Err.Description & vbCrLf & "Номер: " & Err.Number, vbExclamation, "Ошибка"
End Sub
' вызов в теле процедуры: SaveCopy (без Call)
' сохраняет файлы на диск C
Комментариев нет:
Отправить комментарий