Save numbered versions of a document.

Sometimes when working with Word documents, you may wish to save numbered (and dated) versions of the document for future reference. The following macro was based on a simple numbering macro written by fellow Word MVP Doug Robbins and should be attached to a personal toolbar button.

When activated, the macro stores the current date in the format indicated in blue. It then checks whether the document has been saved by looking for the ".doc" extension that Word appends to a filename. If this is not present, you are given the opportunity to save the file with your own choice of name and location. The macro then checks the filename again and strips the extension. If the file in question is already one that has been created as a version by this macro the version details are also stripped.

The version numbers for each named document are stored in the registry at:

HKEY_CURRENT_USER\Software\Microsoft\Office\Word\Settings\

If this key doesn't exist, the macro creates it.

Finally the macro increments the version number and recreates a filename based on the original stripped filename with the addition of the version number and date. The result can be seen in the second illustration.

Sub SaveNumberedVersion()
'Graham Mayor 15 Jan 2006
'Revised 21 Jan 2006 to store data in registry
'Revised 25 June 2007 to impriove compatibility with Word 2007
'Loosely based on code by Doug Robbins

Dim WSHShell, RegKey, rkeyWord, Result
Set WSHShell = CreateObject("WScript.Shell")
Dim iCount As Integer
Dim strDate As String
Dim strPath As String
Dim strFile As String
Dim strFileType As WdDocumentType
Dim strVersionName As String
Dim intPos As Integer
Dim sExt As String

strDate = Format((Date), "dd MMM yyyy")

'Check whether this is Word 2007 and apply relevant settings
If Application.Version = 12 Then
    sExt = ".docx"
    strFileType = wdFormatXMLDocument
Else
    sExt = ".doc"
    strFileType = wdFormatDocument
End If

With ActiveDocument
    On Error GoTo CancelledByUser
    If Len(.Path) = 0 Then 'No path means document not saved
        .Save 'So save it
    End If
    strPath = .Path 'Get path
    strFile = .Name 'Get document name
End With

intPos = InStr(strFile, " - ") 'Mark the version number
If intPos = 0 Then 'No version number
    intPos = InStrRev(strFile, ".doc") 'Mark the extension instead
End If
strFile = Left(strFile, intPos - 1) 'Strip the extension or version number

Start: 'Get Registry Data
RegKey = "HKEY_CURRENT_USER\Software\Microsoft\Office\Word\Settings\"
On Error Resume Next 'No entry in registry will flag an error
rkeyWord = WSHShell.RegRead(RegKey & strFile)
If rkeyWord = "" Then 'Registry entry does not exist
    WSHShell.regwrite RegKey & strFile, 0 'So create it
    GoTo Start:
End If

iCount = Val(rkeyWord) + 1 'Increment number
WSHShell.regwrite RegKey & strFile, iCount 'And write it to the registry

'Define the new version filename
strVersionName = strPath & "\" & strFile & " - " & strDate & _
" - Version " & Format(iCount, "00#") & sExt
'and save a copy of the file with that name
ActiveDocument.SaveAs strVersionName ', strFileType

Exit Sub

Sub SaveNumberedVersion2()
'Graham Mayor 15 Jan 2006

'Modified 25 Jun 2007 for improved compatibility with Word 2007
'similar to the previous version

'But stores data in a text file
Dim strDate As String
Dim strPath As String
Dim strFile As String
Dim sExt As String
Dim strFileType As WdDocumentType
Dim SettingsFile As String
Dim strVersionName As String
Dim intPos As Integer

SettingsFile = Options.DefaultFilePath(wdStartupPath) & "\Settings.txt"
strDate = Format((Date), "dd MMM yyyy")
If Application.Version = 12 Then
    sExt = ".docx"
    strFileType = wdFormatXMLDocument
Else
    sExt = ".doc"
    strFileType = wdFormatDocument
End If


With ActiveDocument
    On Error GoTo CancelledByUser
    If Len(.Path) = 0 Then 'No path means document not saved
        .Save 'So save it
    End If
    strPath = .Path 'Get path
    strFile = .Name 'Get document name
End With

intPos = InStrRev(strFile, " - Version") 'Mark the version number
If intPos = 0 Then 'No version number
    intPos = InStrRev(strFile, ".doc") 'Mark the extension instead
End If
strFile = Left(strFile, intPos - 1) 'Strip the extension or version number
Order = System.PrivateProfileString(SettingsFile, _
"MacroSettings", strFile) 'Lookup the current number
If Order = "" Then 'Increment that number by 1
    Order = 1
Else
    Order = Order + 1
End If

System.PrivateProfileString(SettingsFile, "MacroSettings", _
strFile) = Order 'Update the number record
'Define the new version filename
strVersionName = strPath & "\" & strFile & " - Version " & _
Format(Order, "000#") & " - " & strDate & sExt
'and save a copy of the file with that name

ActiveDocument.SaveAs strVersionName, strFileType
Exit Sub

CancelledByUser: 'Error handler
MsgBox "Cancelled By User", , "Operation Cancelled"
End Sub
 

If you don't know what to do with macro listings see - Installing Macros From Listings