Option Explicit
'/////////////// Buttons /////////////////
Private Sub btnCancel_Click()
Unload Me
End Sub
Private Sub btnSave_Click()
Dim sDocPath As String, sDocName As String, sMsg As String
Dim i As Integer
' set up path and file name
sDocPath = tbDir
sDocName = tbName & "_" & tbDate & ".docx"
' save the file as normal .docx
On Error Resume Next ' Defer error handling.
Err.Clear
ThisDocument.SaveAs2 FileName:=sDocPath & sDocName, _
fileformat:=wdFormatXMLDocument
' Check for error, then show message.
If Err.Number <> 0 Then
sMsg = "Error while trying to save file." & vbCrLf & _
"Please check filename and path"
MsgBox sMsg, , "Error saving"
On Error GoTo 0
Else
On Error GoTo 0
' remove macro button
For i = ThisDocument.InlineShapes.Count To 1 Step -1
With ThisDocument.InlineShapes(i)
If .OLEFormat.Object.Name = "CommandButton1" Then
.Delete
End If
End With
Next
btnCancel_Click
End If
ThisDocument.Save
End Sub
'///////////// Text Boxes ////////////////
Private Sub tbDate_Change()
'enable save button if all three fields filled
btnSave.Enabled = Len(tbDir) * Len(tbName) * Len(tbDate)
End Sub
Private Sub tbDate_Exit(ByVal Cancel As MSForms.ReturnBoolean)
'check if valid date, else set back to today
If Not IsDate(tbDate) Then
tbDate = Date
Cancel = True
End If
End Sub
Private Sub tbDir_Change()
'enable save button if all three fields filled
btnSave.Enabled = Len(tbDir) * Len(tbName) * Len(tbDate)
End Sub
Private Sub tbDir_Enter()
'if user enters the textbox to change then folder picker opens
Dim sPath As String
sPath = GetFolder
' replace contents of textbox if user picked a folder
If Len(sPath) Then tbDir = sPath
End Sub
Private Sub tbDir_Exit(ByVal Cancel As MSForms.ReturnBoolean)
Dim sSep As String
'check path ends with separator
If Len(tbDir) Then
If InStr(tbDir, "/") Then sSep = "/" Else sSep = "\"
If Right(tbDir, 1) <> sSep Then
tbDir = tbDir & sSep
End If
End If
End Sub
Private Sub tbName_Change()
Const sInvalid As String = "*.""/\[]:;|=,<>?"
Dim i As Integer
'replace any invalid characters the user types with "_"
If InStr(1, sInvalid, Right(tbName, 1)) Then
tbName = Left(tbName, Len(tbName) - 1) & "_"
End If
'enable save button if all three fields filled
btnSave.Enabled = Len(tbDir) * Len(tbName) * Len(tbDate)
End Sub
'//////////////////// Userform ///////////////////////////
Private Sub UserForm_Activate()
Dim rbRB As MSForms.ReturnBoolean
tbDate = Format(Date, "yyyy-mm-dd")
tbDir = Options.DefaultFilePath(wdStartupPath)
tbDir_Exit rbRB
End Sub
'//////////////// Support Subs / Functions //////////////////
Function GetFolder() As String
Dim fldr As FileDialog
Dim sItem As String
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
.Title = "Select a Folder"
.AllowMultiSelect = False
.InitialFileName = Options.DefaultFilePath(wdDocumentsPath)
If .Show <> -1 Then GoTo NextCode
sItem = .SelectedItems(1)
End With
NextCode:
GetFolder = sItem
Set fldr = Nothing
End Function