среда, 20 ноября 2013 г.

WinRAR archive copy from Access VBA to Excel/Word


Процедура архивирования экспортируемого файла из 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 

Комментариев нет:

Отправить комментарий

Постоянные читатели

Популярные сообщения