nevets2001uk
IS-IT--Management
We have recently migrated our data from an old fileserver to a new one. One major issue we are facing is that the attached templates all point to the old server location. Since we also redesigned the directory structure this is tricky to correct.
I have hacked together the following code (below) from some examples on the web and some of my own tweaks. It prompts for a directory and then loops through the word files replacing the attached template with normal.dot instead. After that it goes through the first layer of sub directories.
I'd like to modify it so it will work through any number of layers of sub directories as some of the nested levels on our network are much bigger and at the moment it only works on 1 layer. This required much manual intervention to start it off at the right level and is very time consuming.
I'd like to let it run over night going through all folders and numerous layers of subfolders for a specific share. Is this going to be possible?
Steve G (MCSE / MCSA:Messaging)
I have hacked together the following code (below) from some examples on the web and some of my own tweaks. It prompts for a directory and then loops through the word files replacing the attached template with normal.dot instead. After that it goes through the first layer of sub directories.
I'd like to modify it so it will work through any number of layers of sub directories as some of the nested levels on our network are much bigger and at the moment it only works on 1 layer. This required much manual intervention to start it off at the right level and is very time consuming.
I'd like to let it run over night going through all folders and numerous layers of subfolders for a specific share. Is this going to be possible?
Code:
Sub CallChangeTemplates()
Dim lcCurrentDir As String
lcCurrentDir = InputBox("What is the folder location that you want to use?")
'If Right(strFilePath, 1) <> "\" Then strFilePath = strFilePath & "\"
'lcCurrentDir = "C:\Documents and Settings\URathnayake\My Documents\Expert Exchange\Skip write - Password protected"
PcLogFileName = lcCurrentDir + "\" + "DocumentAccessSummery.txt"
ChangeTemplates lcCurrentDir, "*.doc*"
End Sub
Sub ChangeTemplates(lcFilePath As String, strFilePattern As String)
Dim loFileSystemObject, loDirectoryList As Object
Dim lcLogString, lcChildDirectoryName, lcDirectoryPath, lcFileName, lcFileFullPath As String
' Create an object form the filesystem object
Set loFileSystemObject = CreateObject("Scripting.FileSystemObject")
' Get the list of clients. Note: Folders should be named with the patner names
Set loDirectoryList = loFileSystemObject.GetFolder(lcFilePath).SubFolders
Set loFileList = loFileSystemObject.GetFolder(lcFilePath).Files
' Traverse through the files
For Each loFile In loFileList
' Get the file name to a variable to be used below
lcFileName = loFile.Name
' Check only for word files
If InStr(1, lcFileName, "doc") > 0 And Not InStr(1, lcFileName, "~$") = 1 Then
' Construct the full path of the document
lcFileFullPath = lcFilePath & "\" & lcFileName
' Check whether the file is open
If Not IsFileOpen(lcFileFullPath) Then
' Checks the file is password protected
On Error Resume Next
Set Doc = Application.Documents.Open(lcFileFullPath, , , , "**")
' File is password protected
If Err > 0 Then
Update_Log ("File: " + lcFileFullPath + " is Password protected. (ERROR)")
Else
If Doc.ProtectionType <> wdNoProtection Then
Doc.Unprotect
End If
Doc.AttachedTemplate = NormalTemplate
Doc.Close wdSaveChanges
Update_Log ("File: " + lcFileFullPath + " was processed.")
End If
Else
Update_Log ("File: " + lcFileFullPath + " is in use. (ERROR)")
End If
End If
Next
' Traverse to each client folder to check get the available reports
For Each loDirectory In loDirectoryList
' Get the Name of the processing client
lcChildDirectoryName = loDirectory.Name
' Get the full path of the client directory
lcDirectoryPath = loDirectory.Path
' Get the list of files under the client folder to be searched for MSR reports and procees with the updating
Set loFileList = loFileSystemObject.GetFolder(lcDirectoryPath).Files
' Traverse through the files
For Each loFile In loFileList
' Get the file name to a variable to be used below
lcFileName = loFile.Name
' Check only for word fiels without the temporary files
If InStr(1, lcFileName, "doc") > 0 And Not InStr(1, lcFileName, "~$") = 1 Then
' Construct the full path of the document
lcFileFullPath = lcDirectoryPath & "\" & lcFileName
' Check whether the file is open
If Not IsFileOpen(lcFileFullPath) Then
' Checks the file is password protected
On Error Resume Next
Set Doc = Application.Documents.Open(lcFileFullPath, , , , "**")
' File is password protected
If Err > 0 Then
Update_Log ("File: " + lcFileFullPath + " is Password protected (ERROR).")
Else
If Doc.ProtectionType <> wdNoProtection Then
Doc.Unprotect
End If
Doc.AttachedTemplate = NormalTemplate
Doc.Close wdSaveChanges
Update_Log ("File: " + lcFileFullPath + " was processed.")
End If
Else
Update_Log ("File: " + lcFileFullPath + " is in use. (ERROR)")
End If
End If
Next
Next
loFileSystemObject.Delete
loDirectoryList.Delete
End Sub
Function IsFileOpen(lcFileName As String)
Dim lnFileNum As Integer, lnErrNum As Integer
On Error Resume Next ' Turn error checking off.
lnFileNum = FreeFile() ' Get a free file number.
' Attempt to open the file and lock it.
Open lcFileName For Input Lock Read As #lnFileNum
Close lnFileNum ' Close the file.
lnErrNum = Err ' Save the error number that occurred.
On Error GoTo 0 ' Turn error checking back on.
' Check to see which error occurred.
Select Case lnErrNum
' No error occurred.
' File is NOT already open by another user.
Case 0
IsFileOpen = False
' Error number for "Permission Denied."
' File is already opened by another user.
Case 70
IsFileOpen = True
' Another error occurred.
Case Else
Error lnErrNum
End Select
End Function
Function Update_Log(lcString As String)
If Not IsEmpty(lcString) Then
lcString = FormatDateTime(Date, vbLongDate) + " : " + FormatDateTime(Time, vbLongTime) + " : " + lcString
cfilename = FreeFile()
On Error Resume Next
Open PcLogFileName For Append As cfilename
Print #cfilename, lcString
Close #cfilename
Err
End If
End FunctionSteve G (MCSE / MCSA:Messaging)
