Macro to change all text color to black in all docx files in a selected folder

joewoods · #1 01-26-2016, 04:44 PM

Hi guys! I'm trying to put together a macro that changes all the text to black in multiple docx files in a given folder. This is what I have.. but it's not working. Any suggestions?

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
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
    Selection.WholeStory
    Selection.Font.Color = -587137025
    .Close SaveChanges:=True
  End With
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
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

macropod · #2 01-26-2016, 05:34 PM

Try:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If ThisDocument.FullName <> strFolder & "\" & strFile Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      .Range.Font.ColorIndex = wdBlack
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
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

Note: I don't really recommend changing font colours directly; it's much better to redefine the colours in the Styles (assuming that's how the colours have been applied). Also, the default colour (which usually appears as black), isn't wdBlack but wdAuto.

gmayor · #3 01-27-2016, 09:32 AM

It should work for the document body, but for more complex documents, use the following in place of
Selection.WholeStory
Selection.Font.Color = -587137025

Code:

Dim oStory As Range
    For Each oStory In wdDoc.StoryRanges
        oStory.Font.ColorIndex = wdBlack
        If oStory.StoryType <> wdMainTextStory Then
            While Not (oStory.NextStoryRange Is Nothing)
                Set oStory = oStory.NextStoryRange
                oStory.Font.ColorIndex = wdBlack
            Wend
        End If
    Next oStory

macropod · #4 01-27-2016, 02:59 PM

joewoods; Kindly don't post the same question multiple times. As you can see, all it does is waste peoples' time, having different people going over the same ground and risks causing confusion.

Threads merged.

joewoods · #5 01-27-2016, 09:18 PM

Thanks so much, Paul!! Sorry I posted it twice. I just tried it. It works, but not on the text in the header and footer. Is there a way to make it select that text as well?

macropod · #6 01-27-2016, 10:52 PM

Try:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document, Rng As Range
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If ThisDocument.FullName <> strFolder & "\" & strFile Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      For Each Rng In .StoryRanges
        Rng.Font.ColorIndex = wdBlack
      Next
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
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

joewoods · #7 01-28-2016, 12:13 AM

Thanks Paul! It worked! You're a life saver!!

Would you happen to know if it's possible to create a separate macro which would convert all my docx files to pdfs (or create new ones) using the built in microsoft 'save to pdf' plugin? I keep trying to do it by selecting all the files in explorer and then right clicking and using adobe but it keeps crashing.

macropod · #8 01-28-2016, 02:49 AM

Saving to PDF is a trivial exercise. For example:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If ThisDocument.FullName <> strFolder & "\" & strFile Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      .SaveAs FileName:=Split(.FullName, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
      .Close SaveChanges:=False
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
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

Note how little difference there is from the previous code.

joewoods · #9 01-28-2016, 02:09 PM

Thanks Pete! Yup, that worked!!

I just realized that the previous macro for the text color is only changing the font color in the header that is on the first page. Each page has a table withing the header (with different characters in it), and the macro doesn't seem to be getting the characters in the tables past the first page. Is there a way to fix this?

macropod · #10 01-28-2016, 02:15 PM

Quote:

Originally Posted by joewoods

Thanks Pete! Yup, that worked!!

Umm, hello - I'm not Pete...

Quote:

Originally Posted by joewoods

I just realized that the previous macro for the text color is only changing the font color in the header that is on the first page. Each page has a table withing the header (with different characters in it), and the macro doesn't seem to be getting the characters in the tables past the first page. Is there a way to fix this?

Try:

Code:

Sub UpdateDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, wdDoc As Document, Rng As Range, Sctn As Section, HdFt As HeaderFooter
strFolder = GetFolder
If strFolder = "" Then Exit Sub
strFile = Dir(strFolder & "\*.docx", vbNormal)
While strFile <> ""
  If ThisDocument.FullName <> strFolder & "\" & strFile Then
    Set wdDoc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDoc
      For Each Rng In .StoryRanges
        Rng.Font.ColorIndex = wdBlack
      Next
      For Each Sctn In .Sections
        For Each HdFt In Sctn.Headers
          With HdFt
            If .LinkToPrevious = False Then .Range.Font.ColorIndex = wdBlack
          End With
        Next
        For Each HdFt In Sctn.Footers
          With HdFt
            If .LinkToPrevious = False Then .Range.Font.ColorIndex = wdBlack
          End With
        Next
      Next
      .Close SaveChanges:=True
    End With
  End If
  strFile = Dir()
Wend
Set wdDoc = Nothing
Application.ScreenUpdating = True
End Sub
 
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

joewoods · #11 01-28-2016, 02:21 PM

So sorry Paul!! My office mate is Pete!! I am doing a million things at once. Please accept my apologies. Will try running the new code right now and let you know.

joewoods · #12 01-28-2016, 02:29 PM

Yup, works like a charm Paul!! You're the boss!! Thank you so much!!

RageEng177 · #13 05-16-2016, 06:17 PM

Hey Paul,
I'm trying this code, but I'm finding that it's not able to capture the content in the header tables after a page/section break. Can you please help with this?

macropod · #14 05-16-2016, 06:29 PM

The macro processes all headers & footers, including tables in them. The only tables it might not process in a header/footer is one that's in a textbox; but then I'd have to ask why you'd have such a table.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Run a macro on multiple docx. files	Peter Carter	Word VBA	27	12-15-2022 04:10 PM
I can't change red text to black	Nathan8752	Word	1	10-12-2015 08:26 AM
macro to change name of files in a folder in order	expert4knowledge	Word VBA	5	07-10-2014 03:54 PM
Word Macro - change date in footer for all files in a folder	patidallas22	Word VBA	2	03-09-2012 08:14 AM
Change cell color everytime a value is selected in dropdown list	angelica_gloria	Excel	4	01-27-2012 06:47 PM