Програмное сохранение книги на флешку.

[nemoomen]

Господа прошу подсказать!

Работаем в постоянно открытой книге, находящейся на одном из компов в сетке. Необходимо нарабортанную на данный момент книгу "сбросить" на носитель ( желательно програмно в VBA) и при этом "не уйти" вместе с книгой на флешку.

Есть такая возможность?

[EducatedFool]

Такая возможность есть:

Sub Save_ThisWorkbook_Copy()    ' сохраняет копию файла
    ThisWorkbook.SaveCopyAs "e:\Workbook_Backup " & Format(Now, "dd-mmm-yyyy hh-mm-ss") & ".xls"
End Sub

При этом текущее имя и путь файла не изменяются.
Сохранённая копия получает имя типа Workbook_Backup 28-фев-2009 23-00-37.xls

Замените в коде букву диска e: на букву флеш-диска.

Очень удобно такому макросу назначить горячую клавишу, и время от времени в течение работы с документом запускать этот макрос.
Благодаря присутствию в имени файла текущего времени, новые копии не будут затирать старые.

Есть возможность макросом создавать ZIP-архив (средствами Windows), или RAR \ SFX-архив средствами WinRAR
(у архива SFX расширение exe)

Пример создания SFX-архива описан здесь: http://forum.developing.ru/showpost....4&postcount=10
То есть, при желании из VBA можно создавать запароленный архив нужных файлов из выбранной папки с указанием текущего времени.

Пример кода для создания ZIP-архива:

Sub Zip_thisWorkbook()
    DefPath = "e:\"
    'Create date/time string and the temporary xls/zip file names
    strDate = Format(Now, " dd-mmm-yy h-mm-ss")
    FileNameZip = DefPath & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & strDate & ".zip"
    FileNameXls = DefPath & Left(ThisWorkbook.Name, Len(ThisWorkbook.Name) - 4) & strDate & ".xls"
    If Dir(FileNameZip) = "" And Dir(FileNameXls) = "" Then
        'Make copy of the thisWorkbook
        ThisWorkbook.SaveCopyAs FileNameXls         'Create empty Zip File
        NewZip (FileNameZip)         'Copy the file in the compressed folder
        Set oApp = CreateObject("Shell.Application")
        oApp.Namespace(FileNameZip).CopyHere FileNameXls       'Keep script waiting until Compressing is done
        On Error Resume Next
        Do Until oApp.Namespace(FileNameZip).Items.Count = 1
            Application.Wait (Now + TimeValue("0:00:01"))
        Loop
        On Error GoTo 0
    End If
    Kill FileNameXls    ' удаляем временно созданный файл Excel
    MsgBox "Создан архив:  " & FileNameZip, vbInformation, "Готово"
    'Set fs = CreateObject("Scripting.FileSystemObject"):    'fs.MoveFile FileNameZip, "d:\"
End Sub

Sub NewZip(sPath)
    If Len(Dir(sPath)) > 0 Then Kill sPath
    Open sPath For Output As #1
    Print #1, Chr$(80) & Chr$(75) & Chr$(5) & Chr$(6) & String(18, 0)
    Close #1
End Sub

[nemoomen]

Превеликая моя благодарность, мастер Йодо!!!

[ivanant]

а подскажите как подправить код,
Sub Save_ThisWorkbook_Copy() ' сохраняет копию файла
ThisWorkbook.SaveCopyAs "e:\Workbook_Backup " & Format(Now, "dd-mmm-yyyy hh-mm-ss") & ".xls"
End Sub

если файл уже такой существует, чтобы процедура добавляла к имени _1, _2 и тд

[vostok]

Сообщение от ivanant

а подскажите как подправить код,
Sub Save_ThisWorkbook_Copy() ' сохраняет копию файла
ThisWorkbook.SaveCopyAs "e:\Workbook_Backup " & Format(Now, "dd-mmm-yyyy hh-mm-ss") & ".xls"
End Sub

если файл уже такой существует, чтобы процедура добавляла к имени _1, _2 и тд

НЕ существует, т.к. имя меняется ежесекундно

Sub Save_ThisWorkbook_Copy()    ' сохраняет копию файла
    ThisWorkbook.SaveCopyAs "e:\Workbook_Backup " & Format(Now, "dd-mmm-yyyy hh-mm-ss") & ".xls"
End Sub