Sub Document_New()
Dim StrDefPath As String, StrTmpPath As String
Dim RefFile As String, RefNum As String, Rng As Range
'Indicate the default save path for files created from this template,
' including the final '\'.
StrTmpPath = "Filepath for documents based on this template"
StrDefPath = Options.DefaultFilePath(wdDocumentsPath)
Options.DefaultFilePath(wdDocumentsPath) = StrTmpPath
RefFile = Options.DefaultFilePath(wdWorkgroupTemplatesPath) & "\RefNumber.txt"
If Dir(RefFile) = "" Then
  'If the Reference Number File file in the Word Workgroup folder, create it
  RefNum = 0
  Open RefFile For Output As #1
  Write #1, RefNum
  Close #1
End If
'Read the Reference Number File file in the Word Workgroup folder
Open RefFile For Input As #1
Input #1, RefNum
Close #1
' Increment the Reference Number
RefNum = RefNum + 1
DoEvents
'Update the Reference Number File file in the Word Workgroup folder
Open RefFile For Output As #1
Write #1, RefNum
Close #1
'Update the Reference Number in the document and prompt to save
With ActiveDocument
  .CustomDocumentProperties("RefNum") = RefNum
  Application.ScreenUpdating = False
  For Each Rng In ActiveDocument.StoryRanges
    Rng.Fields.Update
  Next
  Application.ScreenUpdating = True
  With .Dialogs(wdDialogFileSaveAs)
    .Name = StrTmpPath & RefNum
    .Show
  End With
End With
Options.DefaultFilePath(wdDocumentsPath) = StrDefPath
End Sub
 
Sub ResetReferenceNumber()
Dim RefFile As String, RefNum As String
'Re-set the Reference Number File file in the Word Workgroup folder
RefFile = Options.DefaultFilePath(wdWorkgroupTemplatesPath) & "\RefNumber.txt"
Open RefFile For Input As #1
Input #1, RefNum
Close #1
RefNum = Trim(InputBox("What is the last valid Reference Number?" & vbCrLf & _
  "The current number is: " & RefNum))
If IsNumeric(RefNum) Then
  If CInt(RefNum) = RefNum Then
    Open RefFile For Output As #1
    Write #1, CInt(RefNum)
    Close #1
    Exit Sub
  End If
End If
MsgBox "Re-numbering error, please try again."
End Sub