(Word365] Intercept all save attempts
I am creating an automated template in VBA for Word365 and it is kicking my butt because of one problem I can't seem to solve. I am creating a document to function as a simple backup for when our dispatching software goes down. The documents will create a record of every incident we handle until the system is restored. All of the documents will be saved in a single folder on the network visible from the call centers in two different parts of the country. The filename of every saved document will be in the same format. This makes it easy for everyone (in both call centers) to see what incidents have been reported.
I have automated the process of saving each completed document using the same format to the same network folder, but only if the user uses Ctrl + S or F12. It works perfectly. The user hits Ctrl + S and a message pops up letting them know the file is being saved, lets them know the filename, and then lets them know when the save has been successful. However, if anyone saves using File -> Save As, it takes the user to the standard Save window and lets them type their own filename, thus defeating the entire purpose. Here's the code I have so far (I removed the server path):
ThisDocument module
Code:
'Intercepts "Save As" and F12
Sub FileSaveAs()
ForceRestrictedSave
End Sub
'Intercepts "Save" and Ctrl+S
Sub FileSave()
'If the document hasn't been saved yet, force the restricted path
If ActiveDocument.Path = "" Then
ForceRestrictedSave
Else
'If it has already been saved, just save the changes normally
ActiveDocument.Save
End If
End Sub
'The actual "Locked Folder" logic
Private Sub ForceRestrictedSave()
Dim targetFolder As String, autoName As String, fullPath As String
'Targets the save folder using the UNC Network Path (must end with a backslash \}
targetFolder = \\server\path\
'Pulls the generated name from the GetAutoFileName Function
autoName = GetAutoFileName() & ".docx"
fullPath = targetFolder & autoName
'This checks if filename already exists
If Dir(fullPath) <> "" Then
If MsgBox("File '" & autoName & "' already exists. Overwrite?", vbYesNo + vbQuestion) = vbNo Then Exit Sub
End If
'If the filename already exists, this creates a SaveAs2 filename
On Error Resume Next
ActiveDocument.SaveAs2 fileName:=fullPath
'If there is an error, this shows the message box text
If Err.Number <> 0 Then
MsgBox "Save Failed! Check network connection or permissions.", vbCritical
Else
MsgBox "Saved as: " & autoName, vbInformation
End If
On Error GoTo 0
End Sub
And this code in the Module1 (renamed to Utilities)
Code:
Public Function GetAutoFileName() As String
Dim doc As Document: Set doc = ActiveDocument
Dim loc As String, prio As String
Dim incLoc As String
'Checks which Location box is checked using Title
If doc.SelectContentControlsByTitle("LocationE")(1).Checked Then
loc = "DUL"
ElseIf doc.SelectContentControlsByTitle("LocationW")(1).Checked Then
loc = "FTW"
Else
loc = "NoLoc"
End If
'Limits the incidentloc to 40 characters (since filename + filepath character limit is 260)
'Also removes any characters that Windows hates in filenames
incLoc = GetCCTextByTag("incidentloc")
incLoc = Left(incLoc, 40)
'Removes bad characters
incLoc = CleanFileName(incLoc)
'Formats the Priority with a leading "P"
prio = "P" & GetCCTextByTag("Priority")
'Strings it all together (Date-Time-Initials-Loc-Zip-Div-Event-Prio-IncLoc)
'Replaces the slashed and colons from Date and Time to prevent Windows errors
GetAutoFileName = Replace(GetCCTextByTag("Date"), "/", "") & "-" & _
Replace(GetCCTextByTag("Time"), ":", "") & "-" & _
GetCCTextByTag("Initials") & "-" & _
loc & "-" & _
GetCCTextByTag("zip") & "-" & _
GetCCTextByTag("division") & "-" & _
GetCCTextByTag("Event") & "-" & _
prio & "-" & _
GetCCTextByTag("incidentloc")
End Function
'Cleans up the filename by removing characters that can cause issues saving
Private Function CleanFileName(ByVal text As String) As String
Dim i As Integer
Dim badChars As Variant
badChars = Array("/", "\", ":", "*", "?", """", "<", ">", "|", ",")
'Replaces the bad character with an underscore "_"
CleanFileName = text
For i = 0 To UBound(badChars)
CleanFileName = Replace(CleanFileName, badChars(i), "")
Next i
End Function
'Gets text from a tag
Private Function GetCCTextByTag(tagName As String) As String
Dim ccList As ContentControls
Set ccList = ActiveDocument.SelectContentControlsByTag(tagName)
If ccList.Count > 0 Then
GetCCTextByTag = Trim(ccList(1).Range.text)
Else
GetCCTextByTag = "Missing"
End If
End Function
Public Sub AppendAuditTrail(tagName As String, newValue As String)
Dim currentLog As String
Dim newEntry As String
Dim timestamp As String
'Create the entry: [Date Time] User - Field: Value
timestamp = Format(Now, "yyyy-mm-dd HH:mm") & " EST"
newEntry = "[" & timestamp & "] " & Application.userName & _
" | " & tagName & " -> " & newValue
'Retrieve the existing log from Document Variables
On Error Resume Next
currentLog = ActiveDocument.Variables("AuditLog").Value
On Error GoTo 0
'Append the new entry (separated by a pipe or newline)
If currentLog = "" Then
currentLog = newEntry
Else
currentLog = currentLog & vbCrLf & newEntry
End If
'Save it back to the hidden variable
ActiveDocument.Variables("AuditLog").Value = currentLog
End Sub
I need some ideas as to how I can intercept a File -> Save As or File -> Save call from the ribbon. I've tried using a Class Module and Event, but even those attempts failed. Help!
Re: (Word365] Intercept all save attempts
Possibly useful link:
https://stackoverflow.com/questions/...e-as-using-vba
From AI:
Code:
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
If (SaveAsUI = True) Then
MsgBox "Save As is disabled.", vbCritical, "Action Cancelled"
Cancel = True
End If
End Sub
