Creating a backup protected with pw

[pandemic]

Hello,

I want to create a backup excel workbook encrypted with password whenever I hit a button save.

So far I have this but still canīt figure out how to protect all new .xlsm files with password so noone canīt do a change in backup files without knowing a password. Saving and creating backup files in different folder works.

Thanks.

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
   
   
    Dim DestinationFolder   As String
    Dim WbName              As String
    Dim WbExtension         As String
    Dim WbNewPath           As String
    Dim sHostName           As String
   
    sHostName = Environ$("computername")
    
    DestinationFolder = "C:\Users\An\Dropbox\Orders - backup"
   
    If DestinationFolder = "" Or Dir(DestinationFolder, vbDirectory) = vbNullString Then
        MsgBox "The destination folder's path is incorect!", vbCritical, "Wrong folder's path"
        Exit Sub
    End If
       
    WbName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
   
    WbExtension = Right$(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))

    WbNewPath = DestinationFolder & "\" & WbName & sHostName & "(" & Format(Now(), "dd.mm.yyyy - hh.mm") & ")." & WbExtension
   
    ThisWorkbook.SaveCopyAs WbNewPath
   
End Sub

[Arkadi]

I don't think there is a way to add a password with savecopyas, you'd need saveas for that

[pandemic]

Can you please help me to modify my code with Saveas function? Im not sure how to do it with such a complex (for me) needs - date, time and computer name in filename. Thank you for efforts.

[Arkadi]

All you need to change is the save command:

replace:

ThisWorkbook.SaveCopyAs WbNewPath

with:

ThisWorkbook.SaveAs WbNewPath, Password:="test"  'replace "test" with your password.

[pandemic]

Hello Arkadi,

Thanks for your solution but it doesnīt work for me. Kindly see an attachement, it does not dissapear when I hit Yes, No even Cancel

Had to force quit via task manager.
aaa.png
My current code is below

Select Code  copy to clipboard
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    
    Dim WbName              As String
    Dim WbExtension         As String
    Dim WbNewPath           As String
    Dim sHostName           As String
   
    sHostName = Environ$("computername")
    
    If DestinationFolder = "" Or Dir(DestinationFolder, vbDirectory) = vbNullString Then
        MsgBox "The destination folder's path is incorect!", vbCritical, "Wrong folder's path"
        Exit Sub
    End If
       
    WbName = Left(ThisWorkbook.Name, (InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1))
   
    WbExtension = Right$(ThisWorkbook.Name, Len(ThisWorkbook.Name) - InStrRev(ThisWorkbook.Name, "."))

    WbNewPath = DestinationFolder & "\" & "(" & Format(Now(), "dd.mm.yyyy - hh.mm") & ")" & sHostName & "." & WbExtension
   
    ThisWorkbook.SaveAs WbNewPath, Password:="test"
   
End Sub

[pandemic]

I have form which gives me the correct path to dropbox folder depending on which computer is using this workbook.
Variable DestinationFolder is defined in modules like this "Global DestinationFolder As String"

Private Sub CommandButton1_Click()
    DestinationFolder = "C:\Users\Tran\Dropbox\Orders - backup"
    StartForm.Show
    Unload Me
End Sub

Private Sub CommandButton2_Click()
    DestinationFolder = "C:\Users\Bi\Dropbox\Orders - backup"
    StartForm.Show
    Unload Me
End Sub
Private Sub CommandButton3_Click()
    DestinationFolder = "C:\Users\An\Dropbox\Orders - backup"
    StartForm.Show
    Unload Me
End Sub

[Arkadi]

I meant to ask... why is the macro in the workbook_beforesave event?

It is causing problems that way I believe, but I don't know your entire macro routine. The change I suggested also makes the saved workbook the current one at the same time, I think it is getting stuck in a loop. Can this not just be a normal macro you call from somewhere? Then it should work.

[pandemic]

I want to create a whole new protected copy of current workbook in different folder. "SaveAs" is just saving a workbook in specified destination, I believe.


"Private Sub Workbook_AfterSave" provides that this macro will run after hitting a save button.

Do you think, there is a way how to do it? To sum it up:

Create a new copy of protected workbook in specified destination with specified name (date, time, name of computer)

[Arkadi]

Yes we can do it. aftersave is an event. It takes place after saving, so I think we just need to change the structure a bit. Quite busy at work today, so I probably won't get back to you until tomorrow, hopefully with some code

[pandemic]

Hello Arkadi,
just reminding myself about my issue. Was trying to write some code myself but it ended with horrible crash.