This code recursively looks through folders for .doc files and converts them to .docx; however, it errors out when trying to convert files in Protected View. I've already modified settings in Trust Center, but it hasn't resolved the issue. How can this code be modified to work on word documents that open in Protected Mode?
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim colFiles As Collection
Dim strFile
Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
For Each strFile In colFiles
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFile, _
AddToRecentFiles:=False, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFile & "x", FileFormat:=16
.Close
End With
End With
Next strFile
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function
Error
If I click Debug this section is highlighted:
Set objWordDocument = .Documents.Open(FileName:=strFile, _
AddToRecentFiles:=False, Visible:=False)
Related
Recently, my organization changed the name of our One Drive causing hyperlinks in my documents linking to other files in the One Drive to become obsolete.
I am trying to create a VBA script that will ask the user for a directory, go through each word doc in the folder and subfolder (and subfolder's subfolder, etc...) and replace a section of all the hyperlinks. I am new to VBA so please, don't hesitate to point out anything.
So far, this is what I have but I can't get it to change what's in the file, let alone go through all the subfolders:
Sub getDirectory()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim FileSystem As Object
Dim HostFolder As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
'Get the directory from user
If xFd.Show = -1 Then
xFdItem = xFd.SelectedItems(1) & Application.PathSeparator
xFileName = Dir(xFdItem & "*.doc*")
End If
'convert directory into string
With xFd
.Filters.Clear
.AllowMultiSelect = False
.Show
Path = .SelectedItems(1)
End With
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(Path)
End Sub
Sub DoFolder(Folder)
'loop through folders after calling LoopThroughFiles
Dim SubFolder
Dim File
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
For Each File In Folder.Files
' Operate on each file
Call LoopThroughFiles
Next
End Sub
Sub LoopThroughFiles()
Dim xFd As FileDialog
Dim xFdItem As Variant
Dim xFileName As String
Dim h As Hyperlink
Dim sOld As String
Dim sNew As String
Set xFd = Application.FileDialog(msoFileDialogFolderPicker)
Do While xFileName <> ""
With Documents.Open(xFdItem & xFileName)
Application.ScreenUpdating = False
'Replace this:
sOld = "AAAA"
'With this:
sNew = "BBBB"
'Example: C:\Users\Me\AAAA\file.doc ---> C:\Users\Me\BBBB\file.doc
'replace hyperlinks
For Each h In ActiveDocument.Hyperlinks
h.Address = Replace(h.Address, sOld, sNew)
Next h
Application.ScreenUpdating = True
End With
xFileName = Dir
Loop
End Sub
I found this code to change .doc files to .docx files. I would like to modify it so I can specify a top level folder and have it work through it AND every sub-folder. Appreciate any assistance.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim strFile As String
Dim strFolder As String
strFolder = "C:\Temp\doc\"
strFile = Dir(strFolder & "*.doc", vbNormal)
While strFile <> ""
With objWordApplication
Set objWordDocument = .Documents.Open(FileName:=strFolder & strFile, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs FileName:=strFolder & Replace(strFile, "doc", "docx"), FileFormat:=16
.Close
End With
End With
strFile = Dir()
Wend
Set objWordDocument = Nothing
Set objWordApplication = Nothing
End Sub
I suggest switching from Dir to FileSystemObject. With FSO, you can get a folder as an object with GetFolder and then access the Folder Object's files and folders as collections. This enables For Each loops like For Each File In Folder. and then you can do the recursion For Each SubFolder In Folder where you can re-call the macro as if each subfolder was the top level folder.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim strFolder As String
strFolder = "C:\Temp\doc\"
Dim StartingFolder As Object
Set StartingFolder = CreateObject("Scripting.FileSystemObject").GetFolder(strFolder)
FolderToDocx StartingFolder, objWordApplication
Set objWordApplication = Nothing
End Sub
Sub FolderToDocx(Folder As Object, wdApp As Word.Application)
Dim File As Object
For Each File In Folder.Files
If LCase(Split(File.Name, ".")(1)) = "doc" Then SaveToDocx File, wdApp
Next
Dim SubFolder As Object
For Each SubFolder In Folder.Subfolders
FolderToDocx SubFolder, wdApp
Next
End Sub
Sub SaveToDocx(File As Object, wdApp As Word.Application)
With wdApp.Documents.Open(File.Path, AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
.SaveAs Filename:=File.Path & "x"), FileFormat:=16
.Close
End With
End Sub
The file matching expression I did in this answer is just an example. You may want to improve that expression to prevent errors. One error that may come up is with Microsoft Office temp files. They are usually hidden and prefixed with ~$ like ~$Word Document.docx. So to avoid accidentally matching one of those, it would be good to exclude anything with that prefix.
I would recommend splitting out the file searching into a separate function: it's easier to tweak your logic and the main method doesn't get overloaded by the code for finding the files.
Sub TranslateDocIntoDocx()
Dim objWordApplication As New Word.Application
Dim objWordDocument As Word.Document
Dim colFiles As Collection
Dim strFile
Set colFiles = GetMatchingFiles("C:\Temp\doc\", "*.doc")
For Each strFile In colFiles
With objWordApplication
Set objWordDocument = .Documents.Open(Filename:=strFile, _
AddToRecentFiles:=False, ReadOnly:=True, Visible:=False)
With objWordDocument
.SaveAs Filename:=strFile & "x", FileFormat:=16
.Close
End With
End With
Next strFile
End Sub
'Search beginning at supplied folder root, including subfolders, for
' files matching the supplied pattern. Return all matches in a Collection
Function GetMatchingFiles(startPath As String, filePattern As String) As Collection 'of paths
Dim colFolders As New Collection, colFiles As New Collection
Dim fso As Object, fldr, subfldr, fl
Set fso = CreateObject("scripting.filesystemobject")
colFolders.Add startPath 'queue up root folder for processing
Do While colFolders.Count > 0 'loop until the queue is empty
fldr = colFolders(1) 'get next folder from queue
colFolders.Remove 1 'remove current folder from queue
With fso.getfolder(fldr)
For Each fl In .Files
If UCase(fl.Name) Like UCase(filePattern) Then 'check pattern
colFiles.Add fl.Path 'collect the full path
End If
Next fl
For Each subfldr In .subFolders
colFolders.Add subfldr.Path 'queue any subfolders
Next subfldr
End With
Loop
Set GetMatchingFiles = colFiles
End Function
I have a question about reading files within folders. I found this code:
sub sample()
Dim FileSystem As Object
Dim HostFolder As String
HostFolder = "C:\"
Set FileSystem = CreateObject("Scripting.FileSystemObject")
DoFolder FileSystem.GetFolder(HostFolder)
end sub
Sub DoFolder(Folder)
Dim SubFolder
For Each SubFolder In Folder.SubFolders
DoFolder SubFolder
Next
Dim File
For Each File In Folder.Files
' Operate on each file
Next
End Sub
But how would you go about avoiding a specific folder which is within the original one?
Let's say the you have a folder A which in turn has several folder Bs. within these folders, there are the file required but also another folder, always with the same name, let's say C.
How would you filter out folders Cs?
Thank you for your time
You can try something like this:
' List of complete path of files in folder / subfolders
' Needs to add "Microsoft Scripting Runtime" reference to your file
Sub FolderFilesPath(ByVal pFolder As String, ByRef pColFiles As Collection, _
Optional ByVal pGetSubFolders As Boolean, Optional ByVal pFilter As Collection)
Dim sFolder As String
Dim oFSO As New FileSystemObject
Dim oFolder, oSubFolder As Folder
Dim oFile As File
sFolder = IIf(Right(pFolder, 1) <> "\", pFolder & "\", pFolder)
Set oFolder = oFSO.GetFolder(sFolder)
If Not ExistsInCollection(pFilter, sFolder) Then
For Each oFile In oFolder.Files
pColFiles.Add oFile
Next oFile
If pGetSubFolders Then
For Each oSubFolder In oFolder.SubFolders
FolderFilesPath oSubFolder.Path, pColFiles, pGetSubFolders, pFilter
Next
End If
End If
End Sub
' Vba collection contains
Function ExistsInCollection(col As Collection, key As Variant) As Boolean
On Error GoTo err
ExistsInCollection = True
IsObject (col.Item(key))
Exit Function
err:
ExistsInCollection = False
End Function
'------------------------------------------------------------------------------
Sub TestMe()
Dim colFiles As New Collection, sFilePath As Variant
Dim colExcludedFolders As New Collection
Dim sHostFolder As String
sHostFolder = "C:\temp"
With colExcludedFolders
' add folders you want to exclude
.Add sHostFolder & "\C\", sHostFolder & "\C\"
End With
FolderFilesPath ThisWorkbook.Path, colFiles, True, colExcludedFolders
' colFiles contains filtered files
For Each sFilePath In colFiles
With sFilePath
' do what you want with filtered files
Debug.Print .Path & " - " & .Name & " - " & .DateCreated
End With
Next sFilePath
End Sub
I am inserting a bunch of Word documents into one file for post-processing. When all the files are in one folder, I got my script to work. However to make it robust for future work, I'd like to insert Word files from all folders and subfolders (and possible futher subs) from a certain starting point. I followed this Youtube tutorial: https://www.youtube.com/watch?v=zHJPliWS9FQ to consider all folders and subfolders and of course amended it for my particular use.
Sub CombineDocs()
On Error Resume Next
MsgBox "Opening"
On Error GoTo 0
Dim foldername As String 'parent folder
With Application.FileDialog(msoFileDialogFolderPicker)
.AllowMultiSelect = False
.Show
On Error Resume Next
foldername = .SelectedItems(1)
Err.Clear
On Error GoTo 0
End With
Documents.Add
Selection.Style = ActiveDocument.Styles("Heading 1")
Selection.TypeText Text:="Opening text"
Selection.TypeParagraph
Selection.InsertNewPage
Selection.InsertBreak Type:=wdSectionBreakNextPage
ActiveDocument.GoTo(What:=wdGoToPage, Count:=2).Select
Dim fso As Scripting.FileSystemObject
Dim file As Scripting.file
getfolders foldername
End sub
Sub getfolders(foldername)
Set fso = New Scripting.FileSystemObject
Call pastedoc(foldername)
Set fso = Nothing
End Sub
Sub pastedoc(StartFolderPath as String)
Dim file As Scripting.file
Dim subfol As Scripting.folder
Dim mainfolder As Scripting.folder
Set mainfolder = fso.GetFolder(StartFolderPath )
For Each file In mainfolder.Files
If ((InStr(1, LCase(fso.GetExtensionName(file.Path)), "doc", vbTextCompare) > 0) Or _
(InStr(1, LCase(fso.GetExtensionName(file.Path)), "docx", vbTextCompare) > 0)) And _
(InStr(1, file.Name, "~$") = 0) Then
Selection.InsertFile FileName:= _
file.Path _
, Range:="", ConfirmConversions:=False, Link:=False, Attachment:=False
Selection.InsertBreak Type:=wdSectionBreakNextPage
End If
Next file
For Each subfol In mainfolder.SubFolders
pastedoc subfol.Path
Next subfol
End Sub
A difference between my code and the tutorial's is that I define the parent folder in the main code and the tutorial does it in the sub script. As a result I get an
'object required'
error in the 'set mainfolder' line. I tried defining all objects and names between the main code and calling the subs but I still can't get it to work. Any guidance what could fix the code?
One option: assuming the End Sub for CombineDocs was after the getfolders call, you can:
Remove getfolders entirely
In CombineDocs, say pastedoc foldername instead of getfolders foldername
Change the beginning of pastedoc to:
Sub pastedoc(StartFolderPath as String)
Dim fso As Scripting.FileSystemObject ' ** Added
Set fso = New Scripting.FileSystemObject ' ** Added
Dim file As Scripting.file
Dim subfol As Scripting.folder
Dim mainfolder As Scripting.folder
Set mainfolder = fso.GetFolder(StartFolderPath )
' ... (everything else the same)
In general, you need to Dim variables either in the Sub where they are used, or at the top of your module, outside any subs. Please put the Dims inside the Subs whenever you can, since that makes your code much easier to change and maintain.
I have two codes. One will search and name every folder within a directory. The other will list the files and file names within a single folder. I am not proficient enough with VBA to figure this out, so I need StackOverflow!
Here is the File Name Listing program:
Sub Example1()
Dim objFSO As Object
Dim objFolder As Object
Dim objFile As Object
Dim i As Integer
'Create an instance of the FileSystemObject
Set objFSO = CreateObject("Scripting.FileSystemObject")
'Get the folder object
Set objFolder = objFSO.GetFolder("\\fc8fsp01\litho_recipe_amat_data")
i = 1
'loops through each file in the directory and prints their names and path
For Each objFile In objFolder.Files
'print file name
Cells(i + 1, 1) = objFile.Name
'print file path
Cells(i + 1, 2) = objFile.Path
i = i + 1
Next objFile
End Sub
Here is the second code that will navigate sub-folders to write folder names:
Option Explicit
Dim i As Long, j As Long
Dim searchfolders As Variant
Dim FileSystemObject
Sub ListOfFolders()
Dim LookInTheFolder As String
i = 1
LookInTheFolder = "\D: ' As you know; you should modificate this row.
Set FileSystemObject = CreateObject("Scripting.FileSystemObject")
For Each searchfolders In FileSystemObject.GetFolder(LookInTheFolder).SubFolders
Cells(i, 1) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
End Sub
Sub SearchWithin(searchfolders)
On Error GoTo exits
For Each searchfolders In FileSystemObject.GetFolder(searchfolders).SubFolders
j = UBound(Split(searchfolders, "\"))
Cells(i, j) = searchfolders
i = i + 1
SearchWithin searchfolders
Next searchfolders
exits:
End Sub
I need a code that will search all sub folders and list all files contained. Please help D:
Because of speed issues when some of the folders I was accessing were present on a network drive, I wrote a little VBA program that uses the Windows Shell dir command. With the proper arguments, this will return all the files in the base directory; as well as all the subfolders and files and so forth. I have it write the results to a text file, which I then read into Excel for further processing.
Compared with using VBA's DIR or the FSO, this ran about five times faster when the files were on a network drive -- not so noticeable when on the local computer -- but I present it as another approach.
You must set a reference to Windows Script Host Object Model.
sDrive and sBasePath are used to set the starting folder name.
sFileList is where the results will be written into a text file.
The /S argument Displays files in specified directory and all subdirectories.
The /B argument results in omitting heading information and summary
If you run CMD.EXE and look for help on the dir command, you will see an explanation of the other arguments.
Public sDrive As String
Public sBasePath As String
Public Const sFileList As String = "C:\Users\Ron\FileList.txt"
Option Explicit
Sub GetDirTree()
Dim WSH As WshShell
Dim lErrCode As Long
Set WSH = New WshShell
lErrCode = WSH.Run("cmd.exe /c dir """ & sDrive & sBasePath & """/B /S >" & sFileList, 0, True)
If lErrCode <> 0 Then
MsgBox ("Error in GetDirTree: Error Number: " & CStr(lErrCode))
Stop
End If
End Sub
This is the function I use to find all files in a directory.
Public Function RecursiveDir(colFiles As Collection, _
ByVal 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
'Fill colFolders with list of subdirectories of strFolder
If bIncludeSubfolders Then
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
'Garbage collection
Set colFolders = Nothing
End Function
This function will populate a collection of every file name in a given directory. And if you want you can set the bIncludeSubfolders to True, and it will recursively search all subfolders within this directory. To use this function, you need the following:
Dim colFiles As New Collection ' The collection of files
Dim Path As String ' The parent Directory you want to search
Dim subFold As Boolean ' Search sub folders, yes or no?
Dim FileExt As String ' File extension type to search for
Then just set FileExt = "*.*" Which will find every file with every file extension. Hopefully this helps a little more.