Save in two places

menteith · #1 01-20-2016, 08:42 AM

Hi all,

I am very new to VBA so I would like to get some help with a macro I have created (some parts of it were found in the Internet). The macro should save make a backup (in a specified path) of a file that is currently being saved, a procedure that is often discussed since Word lacks of it. I will talk over what I think the macro does and should do.

1. FileSave procedure is intercepted.
2. The macro checks if an active document is saved. If it is, no extra action is required and the macro closes.
3. If an active document in not saved, the usual "Save As" dialogue appears. If the user chooses to not save the file then the macro closes.
4. If document is not saved, the macros saves it.
5. The macro looks for a backup folder. If it is not found, the macro creates it and shows a message box.
6. Then the macro checks if the source folder is the same as the backup folder. If they are the same, the macro shows a message and closes.
7. The active (current) document is copied to the backup folder. If it fails, a message box is displayed.

I tested this macro and it seems to work. However, there is a huge imperfection. When document is modified and the user chooses to close it, a dialogue appears asking if the document should be saved. If the user chooses to do so, the document is saved, but a backup copy is not created - and I would like to create a backup in this situation.

Could you check the macro against errors and suggest how to implement the above-mentioned feature? I am newbie so I am pretty sure that the macro is, to say the least, imperfect and it could be rewritten. I did my best to make it as elegant (e.g. I tried to avoid the GoTo procedure) and short as I could.

Please find the macro below.

Code:

Sub FileSave() 
    Dim source As String 
    Dim DocName As String 
    Dim objF As Object 
    Dim retVal As Long 
     
    backup = "C:\Users\" & Environ("UserName") & "\Documents\BackupWord\" 
     
    With ActiveDocument 
         
        If .Saved Then Exit Sub 
        If .Path = "" Then 
            If Application.Dialogs(wdDialogFileSaveAs).Show <> -1 Then Exit Sub 
        End If 
         'GoTo continue
         
        If Not .Saved Then 
            ActiveDocument.Save 
        End If 
         'continue:
        If Dir(backup, vbDirectory) = "" Then 
            MkDir backup 
            MsgBox "Backup folder has been created.", vbInformation 
        End If 
         
        source = .Path & "\" 
        DocName = .Name 
        If source = backup Then 
            MsgBox "WARNING! Backup folder is the same as the source folder." 
            Exit Sub 
        End If 
         
        Set objF = CreateObject("Scripting.FileSystemObject") 
        retVal = -1 
        On Error Resume Next 
        retVal = objF.CopyFile(source & DocName, _ 
        backup & DocName, True) 
        On Error GoTo 0 
        Set objF = Nothing 
        If retVal <> 0 Then 
            MsgBox "Backup has not been copied to folder " & backup 
        End If 
    End With 
End Sub

macropod · #2 01-20-2016, 11:15 PM

You might want to take a look at: http://www.gmayor.com/automatically_backup.htm

If nothing there suits your needs, you might try something along the lines of:

Code:

Private Sub Document_Close()
Call FileSave
SendKeys "{ESC}"
End Sub
 
Sub FileSave()
Dim BackupPath As String, objF As Object, retVal As Long, Rslt
BackupPath = "C:\Users\" & Environ("UserName") & "\Documents\BackupWord\"
With ActiveDocument
  If .Path = "" Then: If Application.Dialogs(wdDialogFileSaveAs).Show <> -1 Then Exit Sub
  If .Saved = False Then
    Rslt = MsgBox("Do you want to Save Changes?", vbYesNoCancel, "File Save")
    If Rslt = vbNo Then
      .Saved = True
      Exit Sub
    ElseIf Rslt = vbCancel Then
      Exit Sub
    End If
  End If
  .Save
  If Dir(BackupPath, vbDirectory) = "" Then
    MkDir BackupPath
    MsgBox "Backup folder has been created.", vbInformation
  End If
  If .Path & "\" = BackupPath Then
    MsgBox "WARNING! Backup folder is the same as the source folder", vbExclamation
    Exit Sub
  End If
  Set objF = CreateObject("Scripting.FileSystemObject")
  retVal = -1
  On Error Resume Next
  retVal = objF.CopyFile(.FullName, BackupPath & .Name, True)
  On Error GoTo 0
  Set objF = Nothing
  If retVal <> 0 Then MsgBox "Backup has not been copied to folder " & BackupPath, vbExclamation
End With
End Sub

menteith · #3 01-21-2016, 07:04 AM

Quote:

Originally Posted by macropod

If nothing there suits your needs, you might try something along the lines of:

Thank you very much for this. Your solution is simple (and it should be!) and does the trick. There is one thing I would like to have and I cannot achieve on my own.

1. If I open Word (no document opened, just blank page), modify it and choose to close Word, a SaveAs dialog is shown. Is there a chance to show an ordinary Word dialogue asking a question whether a document should be saved or not ot, or to cancel? Currently, in the above-mentioned situation, there is no chance of quitting Word without saving, that is, when I choose not to save, I get back to Word (it does not exit.)

I have also one comment.
If a document exists on, say, harddrive, pendrive etc. and I modify it and choose to save, there is a dialogue box asking whether to save or not. In this situation, saving without asking would be preferred for me. I have changed the macro accordingly. Please see it below.

Code:

Sub FileSave()
Dim BackupPath As String, objF As Object, retVal As Long, Rslt
BackupPath = "C:\Users\" & Environ("UserName") & "\Documents\BackupWord\"
With ActiveDocument
  If .Path = "" Then: If Application.Dialogs(wdDialogFileSaveAs).Show <> -1 Then Exit Sub
  If .Saved = False Then .Save
  If Dir(BackupPath, vbDirectory) = "" Then
    MkDir BackupPath
    MsgBox "Backup folder has been created.", vbInformation
  End If
  If .Path & "\" = BackupPath Then
    MsgBox "WARNING! Backup folder is the same as the source folder", vbExclamation
    Exit Sub
  End If
  Set objF = CreateObject("Scripting.FileSystemObject")
  retVal = -1
  On Error Resume Next
  retVal = objF.CopyFile(.FullName, BackupPath & .Name, True)
  On Error GoTo 0
  Set objF = Nothing
  If retVal <> 0 Then MsgBox "Backup has not been copied to folder " & BackupPath, vbExclamation
End With
End Sub

I have also changed your first macro to exit Word when I choose to do so and if a document is empty.

Code:

Private Sub Document_Close()
Dim blank As Range
For Each blank In ActiveDocument.StoryRanges
If Len(blank.Text) = 0 Then Exit Sub
Next
Call FileSave
SendKeys "{ESC}"
End Sub

macropod · #4 01-21-2016, 02:17 PM

Quote:

Originally Posted by menteith

If I open Word (no document opened, just blank page), modify it and choose to close Word, a SaveAs dialog is shown. Is there a chance to show an ordinary Word dialogue asking a question whether a document should be saved or not ot, or to cancel? Currently, in the above-mentioned situation, there is no chance of quitting Word without saving, that is, when I choose not to save, I get back to Word (it does not exit.)

You could insert:
If Len(Trim(.Range.Text)) = 1 Then Exit Sub
after:
If .Path = "" Then: If Application.Dialogs(wdDialogFileSaveAs).Show <> -1 Then Exit Sub
in the code I posted.

Quote:

Originally Posted by menteith

If a document exists on, say, harddrive, pendrive etc. and I modify it and choose to save, there is a dialogue box asking whether to save or not. In this situation, saving without asking would be preferred for me

Having code that results in the dialogue box opening for every save is the only way I could find to ensure a backup gets created.

menteith · #5 01-22-2016, 09:24 AM

Thanks for you help! I will try to look for a workaround for this.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
in 2013, cannot format 4 dec places in Word Document	Abacus1234	Mail Merge	3	10-23-2013 03:57 PM
Word Documents appear in two places	Drjh68	Word	1	08-25-2013 03:19 PM
Forced extra decimal places	Metamag	Excel	11	08-18-2012 03:10 AM
Mail Merge, Number to 2 Decimal Places	Vampy99	Mail Merge	7	09-25-2011 05:41 AM
My Places	lukewarmbeer	Office	0	07-13-2010 02:33 PM