Private Declare PtrSafe Function CreateHardLink Lib "kernel32.dll" Alias "CreateHardLinkA" ( _
                        ByVal lpFileName As String, _
                        ByVal lpExistingFileName As String, _
               Optional ByVal lpSecurityAttributes As LongPtr) As Long
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
    With ThisWorkbook
        Stop
        If .Saved Then
            Cancel = True
        Else
            Dim HrdLnkPt$
            HrdLnkPt = .Path & "\BackUp\" & _
                Mid$(.Name, 1, Len(.Name) - 5) & Format$(Now, "_yyyymmdd_hhmmss") & ".xlsm"            

            If CreateHardLink(HrdLnkPt, .FullName) = 0 Then
                Debug.Print "неудачная попытка сохранения рез. копии" & vbCr & HrdLnkPt
            End If
        End If
    End With
End Sub