Friday, August 31, 2012

My Word Archiving Macro.

This little macro saved my ass more times than I can count. Open a word document, click this macro (it isn't automatic) and it will save a copy of the work (as YourTitle Time Date.DOC) to a USB drive, and an archive folder on the HD. Yes, it will, from then on until you close the document, continue making unique archives of the document every 20 minutes (or whatever you tell it to).

But wait, it gets better.

It also will leave an easily findable bookmark wherever the cursor is at the time, I use @@. Turning this feature on during editing lets you easily find your place and pick up where you left off again, and it ensures you never lose more than 20 minutes worth of work due to blue screens or power outages.

It's actually two macros


'
Sub Archiving()
' Turns Archiving on
'These are the default settings that work for me
BackupFolder = "G:\word\" 'Sets Where it archives it to
TimeChange = "00:20:00" 'Sets autoSave Time
'
'
TriedIt = False
On Error GoTo Skip
TryAgain:
Open "c:\program files\archives.txt" For Input As #1
Input #1, b
Input #1, T
Input #1, bb
Input #1, PlaceMarker
GoTo SkipOver
'
Skip:
If TriedIt = False Then
Call ChangeSettings
TriedIt = True
GoTo TryAgain
End If
SkipOver:
If PlaceMarker = "NONE" Then PlaceMarker = ""
If b <> "" Then BackupFolder = b
If T <> "" Then TimeChange = T
Close #1
'
If True = ActiveDocument.Saved Then GoTo tink
'
d = Now
For e = 1 To Len(d)
If Mid(d, e, 1) = "/" Then Mid(d, e, 1) = "-"
If Mid(d, e, 1) = ":" Then Mid(d, e, 1) = "-"
Next e
'
a = ActiveDocument
If Left(a, 8) = "Document" Then
a = ActiveDocument.Range(0, 15).Text
For e = 1 To Len(a)
If (Mid(a, e, 1) >= "a" And Mid(a, e, 1) <= "z") Or _
(Mid(a, e, 1) >= "A" And Mid(a, e, 1) <= "Z") Or _
(Mid(a, e, 1) >= "0" And Mid(a, e, 1) <= "9") Then zork = 1 Else Mid(a, e, 1) = " "
Next
a = InputBox("Please change from the generic name " + a, , a)
If a = "" Then a = "Document " + d + ".doc"
If Left(Right(a, 4), 1) <> "." Then a = a + ".doc"
End If
If Len(ActiveDocument.Path) < 2 Then
oldn = "C:\Documents and Settings\Administrator\Desktop\" + a
Else
oldn = ActiveDocument.Path + "\" + a
End If
newn = BackupFolder + Mid(a, 1, Len(a) - 4) + " " + d + Mid(a, Len(a) - 3, 4)
If bb <> "" Then
bb1 = bb
bb = bb + Mid(a, 1, Len(a) - 4) + " " + d + Mid(a, Len(a) - 3, 4)
End If
'
' This inserts an easy to find tag where you are curently looking
'
If PlaceMarker <> "" Then
Selection.MoveRight
Selection.MoveLeft
Selection.TypeText Text:=PlaceMarker
End If
'
On Error GoTo Problem
ActiveDocument.SaveAs FileName:=newn, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
False, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
If bb <> "" Then
ActiveDocument.SaveAs FileName:=bb, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
False, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
End If
'
' Removes the easy to find tag
'
If PlaceMarker <> "" Then
ActiveDocument.Undo
End If
'
ActiveDocument.SaveAs FileName:=oldn, FileFormat:= _
wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
False, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
SaveAsAOCELetter:=False
GoTo tink
'
Problem:
MsgBox "An Error in saving occurred" & Chr(13) & "Check Path " _
& BackupFolder & Chr(13) & "Or" & Chr(13) & bb1, , "Error"
'
'
tink:
'
' This makes it repeat the Rchive later
'
Application.OnTime When:=Now + TimeValue(TimeChange), Name:="Archiving"
StatusBar = "Rchiving ON ..." & TimeChange
TimeRemaining = Now + TimeValue(TimeChange)
End Sub
'
'--------------------------------------------------------------------------------------
'
Sub ChangeSettings()
' AutoSave/Archiving settings
BackupFolder = "G:\word\" 'Sets Where it archives it to
TimeChange = "00:20:00" 'Sets autoSave Time
'
'
' Gets where and when from file
'
On Error GoTo Frog
Open "c:\program files\archives.txt" For Input As #1
Input #1, b, T, bb, PlaceMarker
Frog:
If b <> "" Then BackupFolder = b
If T <> "" Then TimeChange = T
Close #1
tt = T
'
' Asks user for changes
'
b = InputBox("Enter Archiving path:" + Chr(13) + _
"These Have to exist" + Chr(13) + _
"It will not make them." + Chr(13) + _
"Most useful as a Removable drive.", "Archiving Path", BackupFolder)
If b <> "" Then
If Mid(b, Len(b), 1) <> "\" Then b = b + "\"
End If
bb = InputBox("Enter Additional Archiving path:" + Chr(13) + _
"These Have to exist" + Chr(13) _
+ "It will not make them" + Chr(13) + _
"Enter nothing for skip" + Chr(13) + _
"This is most useful as a folder on the HD", "2nd Path", bb)
If bb <> "" Then
If Mid(bb, Len(bb), 1) <> "\" Then bb = bb + "\"
End If
T = InputBox("Enter Time Between saves HH:MM:SS", , TimeChange)
PlaceMarker = InputBox("This inserts whatever you enter" + Chr(13) + _
" at your current location" + Chr(13) + _
"But ONLY in the Archives to help" + Chr(13) + _
" you FIND it, (think bookmark)" + Chr(13) + Chr(13) + _
"Enter nothing for nothing, " + Chr(13) + _
" @< works well", "Place Markers", PlaceMarker)
'
' Updates the Where,when on the file
'
Open "c:\program files\archives.txt" For Output As #1
Write #1, b, T, bb, PlaceMarker
Close #1
If T <> tt Then
Application.OnTime When:=Now + TimeValue(T), Name:="Archiving"
StatusBar = "Rchiving ON ..." & T
End If
End Sub
'

No comments:

Post a Comment