Search This Blog

Thursday, February 22, 2018

VBA Error

I created this post so that I could include the following screen shot in a thread (link below) in the MS Office Forums:


I want to have a macro where I can select a folder and then, for each MS Word document in each sub-folder, refresh the fields. Here's the forum thread: http://www.msofficeforums.com/word-vba/38290-update-fields-all-documents-folder.html

When I consulted the online Help for this error, I saw this:


Might as well have been written in Klingon because I have no idea how to apply the words I read to my macro:


'Part I
Option Explicit
Dim FSO As Object, oFolder As Object, StrFolds As String

'Part II
Sub Main()
Application.ScreenUpdating = False
Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long
TopLevelFolder = GetFolder
StrFolds = vbCr & TopLevelFolder
If FSO Is Nothing Then
Set FSO = CreateObject("Scripting.FileSystemObject")
End If
'Get the sub-folder structure
Set TheFolders = FSO.GetFolder(TopLevelFolder).SubFolders
For Each aFolder In TheFolders
RecurseWriteFolderName (aFolder)
Next
'Process the documents in each folder
For i = 1 To UBound(Split(StrFolds, vbCr))
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
Next
Application.ScreenUpdating = True
End Sub

'Part III
Sub RecurseWriteFolderName(aFolder)
Dim SubFolders As Variant, SubFolder As Variant
Set SubFolders = FSO.GetFolder(aFolder).SubFolders
StrFolds = StrFolds & vbCr & CStr(aFolder)
On Error Resume Next
For Each SubFolder In SubFolders
RecurseWriteFolderName (SubFolder)
Next
End Sub

'Part IV
Sub UpdateDocuments(oFolder As String)
Dim strFolder As String, strFile As String, wdDoc As Document
StrInFolder = oFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
With wdDoc
Call RefreshFields(wdDoc)
.Close SaveChanges:=True
End With
strFile = Dir()
Wend
Set wdDoc = Nothing
End Sub

'Part V
Sub RefreshFields(wdDoc As Document)
Dim oStory As Range, oTOC As TableOfContents, oTOF As TableOfFigures
With wdDoc
For Each oStory In .StoryRanges
oStory.Fields.Update
If oStory.StoryType <> wdMainTextStory Then
While Not (oStory.NextStoryRange Is Nothing)
Set oStory = oStory.NextStoryRange
oStory.Fields.Update
Wend
End If
Next oStory
For Each oTOC In .TablesOfContents
oTOC.Update
Next oTOC
For Each oTOF In .TablesOfFigures
oTOF.Update
Next oTOF
End With
End Sub

'Part VI
Function GetFolder() As String
Dim oFolder As Object
GetFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function

No comments: