Normal.DOT

Option Explicit

Dim WithEvents DocEvents As Application

'====================================================================
Private Sub Document_New()
  Set DocEvents = Application
End Sub

Private Sub Document_Open()
  Set DocEvents = Application
End Sub

'====================================================================
Private Sub DocEvents_DocumentBeforeSave(ByVal Doc As Document, _
                                         SaveAsUI As Boolean, _
                                         Cancel As Boolean)
  Dim BackupPath As String
  Dim Buff() As Byte

  On Error Resume Next

  ' Хитрость. Если файл только что создан, то нам его бэкапить как
  ' раз и не надо. Его не существует.
  If Not IsFileExist(Doc.FullName) Then Exit Sub

  ' Этот каталог можно переопределить. Желательно чтобы он был как
  ' можно короче.
  BackupPath = "D:\Word Backups"

  If Not IsDirExist(BackupPath) Then MkDir BackupPath
  If Err Then
    ajpErr.ErrorDisplay Err, , , BackupPath & vbCrLf & vbCrLf & _
                                 "Can't create backup folder."
    Exit Sub
  End If

  If Right(BackupPath, 1) <> "\" Then BackupPath = BackupPath & "\"
  BackupPath = BackupPath & Replace( _
                                Replace( _
                                    Replace(Doc.FullName, "/", "~"), _
                                "\", "~"), _
                            ":", "~")

  If Not IsDirExist(BackupPath) Then MkDir BackupPath
  If Err Then
    ajpErr.ErrorDisplay Err, , , BackupPath & vbCrLf & vbCrLf & _
                                 "Can't create backup folder."
    Exit Sub
  End If

  If Right(BackupPath, 1) <> "\" Then BackupPath = BackupPath & "\"
  BackupPath = BackupPath & Format(Now, "yyyy\-mm\-dd hh\-nn\-ss") & ".BAK"

  ' Магия. CopyFile пытается открыть файл с записью (нафига?),
  ' поэтому ничего у него не получается. Поэтому сделаем вот
  ' так: сами прочитаем и сами сохраним...
  Buff = ajpFSO.GetFileB(Doc.FullName, True)
  If Err Then
    ajpErr.ErrorDisplay Err, , , Doc.FullName & vbCrLf & vbCrLf & _
                                 "Can't read source file." & _
                                 vbCrLf & vbCrLf & BackupPath
    Exit Sub
  End If

  ajpFSO.PutFileB BackupPath, Buff, True
  If Err Then
    ajpErr.ErrorDisplay Err, , , BackupPath & vbCrLf & vbCrLf & _
                                 "Can't write file to backup location." & _
                                 vbCrLf & vbCrLf & BackupPath
  End If
End Sub

Private Function IsDirExist(ByVal Path As String) As Boolean
  Dim TXT As String

  On Error Resume Next

  TXT = Dir(Path, vbArchive + vbDirectory + vbHidden + _
                  vbNormal + vbReadOnly + vbSystem)
  IsDirExist = CBool(TXT <> "")
End Function

Private Function IsFileExist(ByVal Path As String) As Boolean
  Dim TXT As String

  On Error Resume Next

  TXT = Dir(Path, vbArchive + vbHidden + _
                  vbNormal + vbReadOnly + vbSystem)
  IsFileExist = CBool(TXT <> "")
End Function