VBA Script to change word document template location

[jonwitts]

HI,

We recently moved our Workgroup Templates for Word to a new file server in anticipation of shutting down the old file server for good. We successfully changed the loaction of the Workgroup templates in Microsoft Office with GP, and replicated the file share to the new server. We then shut the server down for good.

Now comes the fun part! All of the documents that were created from any of the workgroup templates on the old server still reference the old server in the document template setting. This is slowing the loading time of these documents right down and casuing masses of uneccessary network traffic.

I have read this VBA Macro script on Microsoft's site ( Documents that have attached templates take a long time to open in Word 2002 and in Word 2003 ), method 3; but can not get it to work...

Can anyone see where I am going wrong?

Cheers

Jon

------------------------------------------

Sub rename_temp_dir()
Dim strFilePath As String
Dim strPath As String
Dim intCounter As Integer
Dim strFileName As String
Dim OldServer As String
Dim NewServer As String
Dim objDoc As Document
Dim objTemplate As Template
Dim dlgTemplate As Dialog

OldServer = "<\\server>"
NewServer = "<\\south_hunsley>"
strFilePath = InputBox("What is the folder location that you want to use?")
If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\"
strFileName = Dir(strFilePath & "*.doc")
Do While strFileName <> ""
Set objDoc = Documents.Open(strFilePath & strFileName)
Set objTemplate = objDoc.AttachedTemplate
Set dlgTemplate = Dialogs(wdDialogToolsTemplates)
strPath = dlgTemplate.Template
If LCase(Left(strPath, 8)) = LCase(OldServer) Then
objDoc.AttachedTemplate = NewServer & Mid(strPath, 9)
End If
strFileName = Dir()
objDoc.Save
objDoc.Close
Loop
Set objDoc = Nothing
Set objTemplate = Nothing
Set dlgTemplate = Nothing

End Sub

[jonwitts]

OK... Found it myself this morning...

It was the < > at the start and end of both server names that was throwing it...

Here is the working version...

Now all I need to do is get it to read through sub folders too...

---------------

Sub rename_temp_dir()
Dim strFilePath As String
Dim strPath As String
Dim intCounter As Integer
Dim strFileName As String
Dim OldServer As String
Dim NewServer As String
Dim objDoc As Document
Dim objTemplate As Template
Dim dlgTemplate As Dialog

OldServer = "\\b091-jonw\templates"
NewServer = "\\south_hunsley\templates"
strFilePath = InputBox("What is the folder location that you want to use?")
If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\"
strFileName = Dir(strFilePath & "*.doc")
Do While strFileName <> ""
Set objDoc = Documents.Open(strFilePath & strFileName)
Set objTemplate = objDoc.AttachedTemplate
Set dlgTemplate = Dialogs(wdDialogToolsTemplates)
strPath = dlgTemplate.Template
If LCase(Left(strPath, 21)) = LCase(OldServer) Then
objDoc.AttachedTemplate = NewServer & Mid(strPath, 22)
End If
strFileName = Dir()
objDoc.Save
objDoc.Close

Loop
Set objDoc = Nothing
Set objTemplate = Nothing
Set dlgTemplate = Nothing

End Sub

[jonwitts]

Just in case anyone else needs this at some point; here is the working Macro to recursively change the workgroup template server setting in Word documents...

---------------------------------------------------------------------------

Sub recursive_rename_temp_dir()

On Error Resume Next

Dim colFiles As New Collection
Dim strFilePath As String
Dim strFileType As String
Dim strFileName As String
Dim OldServer As String
Dim NewServer As String
Dim objDoc As Document
Dim objTemplate As Template
Dim dlgTemplate As Dialog

' Set the name of old and new server here
OldServer = "\\server\templates"
NewServer = "\\south_hunsley\templates"

'Message prompt for folder location
strFilePath = InputBox("What is the folder location that you want to use?")

'Message prompt for file type
strFileType = InputBox("What is the file extension you are looking for, including the dot?")

RecursiveDir colFiles, strFilePath, "*" & strFileType, True

Dim vFile As Variant
For Each vFile In colFiles
Debug.Print vFile

'vFile returns full file path - split it at the last "\" to get file name
strFilePath = vFile

SeparatePathAndFile strFilePath, strFileName

Set objDoc = Documents.Open(strFilePath & strFileName)
Set objTemplate = objDoc.AttachedTemplate
Set dlgTemplate = Dialogs(wdDialogToolsTemplates)
strPath = dlgTemplate.Template

'first number equals number of characters in OldServer string, second number is incremented by one
If LCase(Left(strPath, 18)) = LCase(OldServer) Then
objDoc.AttachedTemplate = NewServer & Mid(strPath, 19)
End If

objDoc.Save
objDoc.Close

Next vFile

End Sub

Private Sub SeparatePathAndFile(ByRef io_strPath As String, ByRef o_strFileName As String)
'io_strPath - Input/output parameter containing the entire path with file name
' - Will Return the path only
'o_strFileName - Output parameter that will contain the name of the File

Dim strPath() As String
Dim lngIndex As Long

strPath() = Split(io_strPath, "\") 'Put the Parts of our path into an array
lngIndex = UBound(strPath)
o_strFileName = strPath(lngIndex) 'Get the File Name from our array
strPath(lngIndex) = "" 'Remove the File Name from our array
io_strPath = Join(strPath, "\") 'Rebuild our path from our array

End Sub

Public Function RecursiveDir(colFiles As Collection, _
strFolder As String, _
strFileSpec As String, _
bIncludeSubfolders As Boolean)

Dim strTemp As String
Dim colFolders As New Collection
Dim vFolderName As Variant

'Add files in strFolder matching strFileSpec to colFiles
strFolder = TrailingSlash(strFolder)
strTemp = Dir(strFolder & strFileSpec)
Do While strTemp <> vbNullString
colFiles.Add strFolder & strTemp
strTemp = Dir
Loop

If bIncludeSubfolders Then
'Fill colFolders with list of subdirectories of strFolder
strTemp = Dir(strFolder, vbDirectory)
Do While strTemp <> vbNullString
If (strTemp <> ".") And (strTemp <> "..") Then
If (GetAttr(strFolder & strTemp) And vbDirectory) <> 0 Then
colFolders.Add strTemp
End If
End If
strTemp = Dir
Loop

'Call RecursiveDir for each subfolder in colFolders
For Each vFolderName In colFolders
Call RecursiveDir(colFiles, strFolder & vFolderName, strFileSpec, True)
Next vFolderName
End If

End Function


Public Function TrailingSlash(strFolder As String) As String
If Len(strFolder) > 0 Then
If Right(strFolder, 1) = "\" Then
TrailingSlash = strFolder
Else
TrailingSlash = strFolder & "\"
End If
End If
End Function

[amywoo]

Hi

Please could you tell me how you did the Gp part?
Regards
Amy

[jonwitts]

Just make sure you have installed the Office Group Policy ADM templates on your servers (you download them from Microsoft...)

[coffeeguy]

Your post has been very helpful. I have the following code which works for one directory:

Sub PointToNormal()

Dim strFilePath As String
Dim strPath As String
Dim intCounter As Integer
Dim strFileName As String
Dim OldServer As String
Dim objDoc As Document
Dim objTemplate As Template
Dim dlgTemplate As Dialog
Dim nServer As Integer

OldServer = InputBox("What is the old path of your template?(full path to file extension)")
nServer = Len(OldServer)
strFilePath = InputBox("What is the folder location that you want to use?")

If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\"

'strFileName = Dir(strFilePath & "*.doc")
strFileName = InputBox("What is the file extension you are looking for, including the dot?")
Do While strFileName <> ""
Set objDoc = Documents.Open(strFilePath & strFileName)
Set objTemplate = objDoc.AttachedTemplate
Set dlgTemplate = Dialogs(wdDialogToolsTemplates)
strPath = dlgTemplate.Template

If LCase(Left(strPath, nServer)) = LCase(OldServer) Then
objDoc.AttachedTemplate = NormalTemplate

End If

strFileName = Dir()
objDoc.Save
objDoc.Close

Loop

Set objDoc = Nothing
Set objTemplate = Nothing
Set dlgTemplate = Nothing


End Sub

Can you help me set this up to parse subfolders that are contained in the FilePath string?

Any help would be much appreciated!

[jonwitts]

Doesn't my code in post #3 work for you?

Jon

[coffeeguy]

Turns out it may. My I.T. team had restored the path where the templates were. I didn't know this when I was testing. It appears that if the old template path is available you can't update the document. I am going to test this tomorrow morning. As soon as I have some results I will update.

I would like to use your code, the only change I would like to is make it point to the normal.dot template instead of a specific path. Like in what I posted. Any suggestions there?

By the way thank you for your reply so many people let there threads go unanswered!

[jonwitts]

Turns out it may. My I.T. team had restored the path where the templates were. I didn't know this when I was testing. It appears that if the old template path is available you can't update the document. I am going to test this tomorrow morning. As soon as I have some results I will update.

I would like to use your code, the only change I would like to is make it point to the normal.dot template instead of a specific path. Like in what I posted. Any suggestions there?

By the way thank you for your reply so many people let there threads go unanswered!

I'm not sure I follow you... The script is specifically for replacing the hard coded WORKGROUP TEMPLATE setting in a Word file... I suppose you could try and point all of your workgroup templates at the local Normal.dot file on each machine, but I am not sure what effect that would have on it... I would maybe try replacing the newserver variable with something like "%systemdrive%\%userprofile%\folders structure to local temp files..." but as I say; that comes with no promises and is completely untested, as I am running Linux at home and have no way of testing...

You would also need to overwrite the name of the current workgroup template file to be Normal.dot too... but that shouldn't be too hard.

Again; not sure why you want to do this.... This script was for a very specific purpose of fixing loads of files that pointed to a non-existent share on a non-existent server... This caused the file (and local PC) to lock up every time the files were opened whilst it broadcast across the whole network trying to find the server...

My advise; always share your workgroup template folder out on a DFS share. That way if you replace a server, you can just add the new one into the DFS Share!

Good luck anyway!

Jon