Лингрин :: Резиденция Линды Кайе

суббота, 22 октября 2011

11:37

Тотальная неудачница и убийца жёстких дисков.

#post-id: 4102-13-25
#original-date: 19.10.2011 Wed
#original-time: 1:25 PM
#original-day: 4102
#original-host: WinXP Home SP3 (Build 2600)

Любимая игра японцев:

- Я так виноват...
- Нет, это я виноват!
- Но я больше виноват!
- Я больше!
- Я!
- Да я тебя!..

В итоге два трупа. /* Ну, про трупы я уже преувеличиваю ^^ */

#video: ikkitousen - 11

URL

11:37

Тотальная неудачница и убийца жёстких дисков.

#post-id: 4102-11-59
#original-date: 19.10.2011 Wed
#original-time: 11:59 AM
#original-day: 4102
#original-host: WinXP Prof SP3 (Build 2600)

Очень полезный код из серии "Возвращение индуса".

Перехватывает попытки сохранить документ и делает резервную копию перед самим сохранением. Тоже самое я реализовала в AJPapps - NoteBook mode for Dana, Yamato Notepad2 и своём билде FocusWriter.

Вставляется в Ворде, в шаблон Normal.DOT в модуль ThisDocument. В константе BACKUP_PATH указываем каталог для бэкапов. Завершающий слэш не обязателен. После всех действий сохраняем шаблон и перезапускаем Ворд.

Option Explicit

Dim WithEvents DocEvents As Application

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

'====================================================================
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 = BACKUP_PATH
  
  If Not IsDirExist(BackupPath) Then MkDir BackupPath
  If Err Then
    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
    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 = GetFileB(Doc.FullName, True)
  If Err Then
    ErrorDisplay Err, , , Doc.FullName & vbCrLf & vbCrLf & _
                          "Can't read source file." & _
                          vbCrLf & vbCrLf & BackupPath
    Exit Sub
  End If
  
  PutFileB BackupPath, Buff, True
  If Err Then
    ErrorDisplay Err, , , BackupPath & vbCrLf & vbCrLf & _
                          "Can't write file to backup location." & _
                          vbCrLf & vbCrLf & BackupPath
  End If
End Sub

'====================================================================
Public Function GetFileB(ByVal FileName As String, _
                         ByVal RaiseErrors As Boolean) As Byte()
  Dim hFile As Long
  
  On Error GoTo hError
  
  If Not IsFileExist(FileName) Then Err.Raise 53
  
  hFile = FreeFile
  Open FileName For Binary Access Read As #hFile
  
  ReDim GetFileB(0 To LOF(hFile) - 1)
  If LOF(hFile) > 0 Then Get #hFile, , GetFileB
  
  Close #hFile
  Exit Function
  
hError:
  If hFile > 0 Then Close #hFile
  Err.Raise Err.Number, Err.Source, Err.Description
End Function

Public Sub PutFileB(ByVal FileName As String, _
                    ByRef Data() As Byte, _
                    ByVal RaiseErrors As Boolean)
  Dim hFile As Long
  
  On Error GoTo hError
  
  If IsFileExist(FileName) Then Kill FileName
  
  hFile = FreeFile
  Open FileName For Binary Access Write As #hFile
  
  Put #hFile, , Data
  
  Close #hFile
  Exit Sub
  
hError:
  If hFile > 0 Then Close #hFile
  Err.Raise Err.Number, Err.Source, Err.Description
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

'====================================================================
Public Sub ErrorDisplay(ByVal ErrX As ErrObject, _
                        Optional ByVal Reserved1 As Long, _
                        Optional ByVal Reserved2 As String, _
                        Optional ByVal Message As String = "Something happens")
  Dim TXT As String
  
  ' Debug...
  'On Error Resume Next
  'Err.Raise 51
  'Set ErrX = Err
  
  If Message <> "" Then TXT = Message & vbCrLf & vbCrLf
  TXT = "Error number: " & FormatErrorNumber(ErrX.Number) & vbCrLf & _
        "Description:  " & ErrX.Description
  'If ErrX.Source <> "" Then TXT = TXT & vbCrLf & "Error source: " & ErrX.Source
  
  MsgBox TXT, vbCritical
End Sub

Private Function FormatErrorNumber(ByVal Number As Long) As String
  Dim HexNum As String
  
  HexNum = UCase(Hex(Number))
  HexNum = String(8 - Len(HexNum), "0")
  
  FormatErrorNumber = CStr(Number) & " (0x" & HexNum & ")"
End Function

Вроде бы определений из внешних мест нет, так что должно работать. Проверяла на Word 2003.

URL