Solved: Preference when saving

I'm trying to force users to save a certain template (their copy of course) as a certain filename. I know I can force them (activedocument.saveas), but that's a bit too much.

Normally, Word gives a new document a standard name, most likely 'document1' or the first line in the document. Is there a possibility that I can change that name into something I want, so that when users save that document for the first time they get a standard preference filename?? (They still should be able to change it into something they want).

I have a clue this isn't gonna work, but anyone??

What you can do is cancel the default SaveAs action and make your own. You can ask for the name with an Input Box and allow the user to browse for a folder to save it to, then have the macro save the file.

I will be using this Kb Entry in my example to get the Folder to save the file to.

In ThisDocument:
[VBA]
Option Explicit

Dim oAppClass As New ThisApplication

Private Sub Document_New()

Set oAppClass.oApp = Word.Application

End Sub
[/VBA]

In a Standard Module:
[vba]
Option Explicit

Sub NewSaveAs(Optional Dummy As Long)

Dim Path As Variant
Dim FName As String
Dim Prompt As String
Dim Title As String
Dim Default As String

Path = BrowseForFolder
If Path = False Then
Exit Sub
End If
Prompt = "What do you want to use for the file name?"
Title = "Save As File Name"
Default = "My File"
FName = InputBox(Prompt, Title, Default)
If FName = "" Then
Exit Sub
End If

ActiveDocument.SaveAs FileName:=Path & "\" & FName

End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant

'Function purpose: To Browser for a user selected folder.
'If the "OpenAt" path is provided, open the browser at that directory
'NOTE: If invalid, it will open at the Desktop level

Dim ShellApp As Object

'Create a file browser window at the default folder
Set ShellApp = CreateObject("Shell.Application"). _
BrowseForFolder(0, "Please choose a folder", 0, OpenAt)

'Set the folder to that selected. (On error in case cancelled)
On Error Resume Next
BrowseForFolder = ShellApp.self.Path
On Error GoTo 0

'Destroy the Shell Application
Set ShellApp = Nothing

'Check for invalid or non-entries and send to the Invalid error
'handler if found
'Valid selections can begin L: (where L is a letter) or
'\\ (as in \\servername\sharename. All others are invalid
Select Case Mid(BrowseForFolder, 2, 1)
Case Is = ":"
If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
Case Is = "\"
If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
Case Else
GoTo Invalid
End Select

Exit Function

Invalid:
'If it was determined that the selection was invalid, set to False
BrowseForFolder = False

End Function
[/vba]
In a Class Module Named ThisApplication:
[vba]
Option Explicit

Public WithEvents oApp As Word.Application

Private Sub oApp_DocumentBeforeSave(ByVal Doc As Document, _

SaveAsUI As Boolean, Cancel As Boolean)
If SaveAsUI = True Then
Cancel = True
Call NewSaveAs
End If

End Sub
[/vba]

Refer to the example template that is attached.

Stupid that I didn't think of that myself. Thanks a lot for the help.

I created an own form instead of the (ugly) Inputbox and of course had to change some things, but it works.

Thanks a lot!!

User Forms are definitely better than Input Boxes since you can make them have whatever look you want. :)

Glad to help :beerchug:

Take Care

Trying to understand the reasoning here.

"when users save that document for the first time they get a standard preference filename?? (They still should be able to change it into something they want)"

If the document IS saved, then that is now the name of the file. If the user "changes" it then:

1. there is an operation of SaveAs - which case there is now a NEW file with the new name;
2. there is an operating system operation that changes the filename.

I don't know what you have as a userFrom, but that is the way to go. I would:

Display, as a label, "File will be saved as..." followed by the filename YOU have chosen (by whatever logic). "Press OK to accept, or type in a new filename then press OK." They can either press OK - which accepts your name, or type in a new name and press OK.

OK simply saves the file by the name you have chosen, or if the texbox is not "", use that name.

Am I missing something?

You're not missing anything. I had to do some other things as well, but that's the solution in a nutshell.

Quote:

---

Originally Posted by M-a-d-m-a-n

You're not missing anything. I had to do some other things as well, but that's the solution in a nutshell.

---

Goedenavond, :D

Seams like you got this thing all worked out.
Could you perhaps attach you're sollution for the benifits of others..(Always a pleasure checking out other peoples work)

Thnxx :thumb

[VBA]
Private Sub CmbNumberOfFiles_Click()
NumberOfFiles = FormMain.lstDocuments.ListCount - 1
MsgBox "The number of files in the list: " & FormMain.lstDocuments.ListCount, vbInformation

End Sub

Private Sub cmdClose_Click()
Unload FormMain
End Sub

Public Sub CmdShow_Click()
lstDocuments.Clear
ReadDirectory ("P:\gws4all\Teksten\modeldocs\body\Beschikkingen")
ReadDirectory ("P:\gws4all\Teksten\modeldocs\body\brieven")
lblStatus.Caption = "Done with reading files..."
lblStatus.BackColor = &HC000&
End Sub

Sub ReadDirectory(Directories)
Static Running As Boolean

Dim AllDirs As New Collection
Dim NextDir As Integer
Dim DirectoryName As String
Dim SubDirectory As String
Dim i As Integer

If Running Then
Running = False
Else
Running = True

NextDir = 1
AllDirs.Add Directories
Do While NextDir <= AllDirs.Count
' Get the next directory to search.
DirectoryName = AllDirs(NextDir)
NextDir = NextDir + 1

' Read directories from DirectoryName.
SubDirectory = Dir$(DirectoryName & "\*.*", vbDirectory + vbNormal)
Do While SubDirectory <> ""
' Add the name to the list if
' it is a directory.
If UCase$(SubDirectory) <> "PAGEFILE.SYS" And _
SubDirectory <> "." And SubDirectory <> ".." _
Then
SubDirectory = DirectoryName & "\" & SubDirectory
On Error Resume Next
AllDirs.Add SubDirectory
End If
SubDirectory = Dir$(, vbDirectory)
Loop

If Not Running Then Exit Do
Loop

For i = 1 To AllDirs.Count
PosPunt = InStr(1, AllDirs(i), ".rtf", 1)
If PosPunt > 0 Then
FormMain.lstDocuments.AddItem txt & AllDirs(i)
End If
lblStatus.BackColor = &HC0&
lblStatus.Caption = "Busy reading files..."
DoEvents
Next i
Running = False
End If
End Sub
Private Sub cmbOpenADocument_Click()
On Error GoTo ErrHandler:
Documents.Open (FormMain.lstDocuments.Value)
ErrHandler:
If Err.Number = "13" Then
MsgBox "No document selected." & vbCrLf & vbCrLf & _
"Select a document and try again.", vbCritical, "No document selected!!!"
Else
Resume Next
End If
End Sub
Private Sub cmdReplaceParagraph_Click()
Dim FilesDone As Integer
Dim FilesNotDone As Integer
Dim FilesReadOnly As Integer
On Error GoTo ErrHandler
NumberOfFiles = FormMain.lstDocuments.ListCount - 1

Documents.Open "H:\Applicatiebeheer\Sjablonen in progress\Alinea-Vragen.doc"
Selection.WholeStory
Selection.Copy
ActiveDocument.Close wdDoNotSaveChanges

For x = 0 To NumberOfFiles
Documents.Open FormMain.lstDocuments.List(x, 0)
If ActiveDocument.ReadOnly = True Then
If ActiveDocument.Bookmarks.Exists("StartOfParagraph") Then
FilesReadOnly = FilesReadOnly + 1
End If
ActiveDocument.Close wdDoNotSaveChanges
Else
If ActiveDocument.Bookmarks.Exists("StartOfParagraph") Then
Set TeVervangenSelectie = ActiveDocument.Range _
(Start:=ActiveDocument.Bookmarks("StartOfParagraph").Range.Start, _
End:=ActiveDocument.Bookmarks("EndOfParagraph").Range.End)

TeVervangenSelectie.Select
Selection.Delete
Selection.Paste
Selection.TypeBackspace
Selection.TypeBackspace
ActiveDocument.Bookmarks.Add ("EndOfParagraph")
ActiveDocument.Close wdSaveChanges
FilesDone = FilesDone + 1
FormResult.LstResult.AddItem FormMain.lstDocuments.List(x, 0)
Else
If ActiveDocument.Name = "Beheer_GWS4All.dot" Then
Exit Sub
Else
ActiveDocument.Close
FilesNotDone = FilesNotDone + 1
GoTo NextFile
End If

End If
End If
NextFile:
Next
lblStatus.Caption = "Done replacing paragraph in files..."
lblStatus.BackColor = &HC000&
MsgBox "Replacement complete." & vbCrLf & vbCrLf & "Files done: " & FilesDone & _
vbCrLf & "Files skipped: " & FilesNotDone & vbCrLf & "Files read-only: " & _
FilesReadOnly, vbInformation, "Complete."
If FilesDone <> "0" Then
FormResult.Show
Else
End If

ErrHandler:
Select Case Err.Number
Case 5941
If ActiveDocument.Name = "Beheer_GWS4All.dot" Then
Exit Sub
Else
ActiveDocument.Close 'wdDoNotSaveChanges
FilesNotDone = FilesNotDone + 1
GoTo NextFile
End If
Case Else
Resume Next
End Select
End Sub

Private Sub cmdClearList_Click()
FormMain.lstDocuments.Clear
lblStatus.Caption = ""
lblStatus.BackColor = &H80000018
End Sub
[/VBA]

The user asked me for this. They manage about 600 rtf-files in which a certain paragraph changes every now and then. Instead of having to manually search each file for that paragraph they only have to create two bookmarks in those files.

The main function of this template is to search all of those files in two directories (including subdirs) for a certain bookmark. If that exists, it creates a selection range between the two bookmarks and replaces it with text from another file. So if they change that one file, all other files will be changed accordingly. There are some other functions as you can see, but that's the main one. It also has another small form in which it shows the replaced files.

I translated it back to English for the non-Dutch boys and girls in here... :)

Hoi, :D

Thnx for posting back. I'm shure it will be used in the future! :thumb