Word macro to Loop through all files and save

[maryidahosas]

I have a word macro recorded that cleans up a .rtf file by hitting cntlG once I have inserted the file into a template .dot. After it is cleaned up, I then save it as a word document. .doc

But, I have 110 files that I have to clean up, so I would like to create a solution that would loop through all .rtf files in a folder, open template, insert .rtf file to be cleaned up into the template, execute the cntlG, and save to the same folder as a .doc. ....and then repeat until all files are complete.

I'm brand new to VB macros, but I do coding in SAS, so I think that I can learn this, but I did not have any luck locating examples by searching the archive. Can anyone help me figure out how to do this???

Below is the cltlG code for the clean up.

Thanks to anyone who can help.

Mary
/***********************************/

Sub RTF_Files_CntrlG()
'
' RTF_Files_CntrlG Macro
' Macro recorded 4/5/2007 by Kristy Patteson
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^b"
.Replacement.Text = "^m"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^d"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.25)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
End With
End Sub

[lucas]

Here's some reading to get you started:
http://vbaexpress.com/kb/getarticle.php?kb_id=76
http://vbaexpress.com/kb/getarticle.php?kb_id=13
I'm not sure why you think you're putting them in a .dot...then to doc though??

[lucas]

I changed the number 13 entry a little so you can see how it can work for you....you will have to add your action to it in the appropriate place...look for it in the comments of the code. You will have to change the path also.
Sub ProcessAll() '(sPath As String)
Dim sPath As String
Dim WdDoc As Document, sFile As String
'Change the path below to suit your need
sPath = "C:\Temp\test\New Folder\"
sFile = Dir(sPath & "*.doc")
'Loop through all .doc files in that path
Do While sFile <> ""
Set WdDoc = Application.Documents.Open(sPath & sFile)

'Do something with that Document, insert whatever you want to do here
' MsgBox used here to show the loop at work
' Comment out the msgbox and replace with your code.
MsgBox WdDoc.Name
'You can save it, if you like, here it's not saved
WdDoc.Close wdDoNotSaveChanges
sFile = Dir
Loop
End Sub

[maryidahosas]

Thanks Lucas!!

The issue is that I need to read in the .rtf file, clean it up and save it as a .doc. I started playing with the entry #76 instead of #13. I tried to modify it to open a .rtf file, run the code and then save as a .doc file, and it looped through the folder, but the resulting .doc files were empty. I'm unsure of how to troubleshoot.

It isn't saving the documents that I modified but just saving empty docs, and I'm guessing that I need to add a statement so that it realizes to save the result of the clean up as the new document....I don't know...

Here's the main part of the program that I modified in my clumsy attempt to get it to do what I wanted.:

/*********************/
Sub OpenAllFiles(strPath As String)

' runs through a folder oPath, opening each file in that folder,
' calling a macro called samp, and then closing each file in that folder

Dim strName As String
Dim wdDoc As Document
Dim countlen As Long
Dim nom As String


If scrFso Is Nothing Then Set scrFso = CreateObject("scripting.filesystemobject")
Set scrFolder = scrFso.getfolder(strPath)
For Each scrFile In scrFolder.Files
strName = scrFile.Name 'the name of this file
Application.StatusBar = strPath & "\" & strName 'the status bar is just to let us know where we are
'we'll open the file fName if it is a rich text document
If Right(strName, 4) = ".rtf" Then
Set wdDoc = Documents.Open(FileName:=strPath & "\" & strName, _
ReadOnly:=False, Format:=wdOpenFormatAuto)

'Call the macro that performs work on the file pasing a reference to it
DoWork wdDoc

'Set new file name with .doc extension to save the new doc
countlen = Len(ActiveDocument.Name)
nom = Left(ActiveDocument.Name, countlen - 4)
ThisDocument.SaveAs FileName:="Z:\workareas\maryworkarea\pwrfactanaly\lsoutres\sites\" & nom & ".doc"

wdDoc.Close wdSaveChanges


End If
Next

'return control of status bar to Word
Application.StatusBar = False
End Sub

[lucas]

Try this Mary...use it all and see if it works for you:
Option Explicit
Sub ProcessAll() '(sPath As String)
Dim sPath As String
Dim wdDoc2 As Document, sFile As String
'Change the path below to suit your need
sPath = "f:\Temp\rtf\"
sFile = Dir(sPath & "*.rtf")
'Loop through all .doc files in that path
Do While sFile <> ""
Set wdDoc2 = Application.Documents.Open(sPath & sFile)

'Do something with that Document, insert whatever you want to do here
' MsgBox used here to show the loop at work
' Comment out the msgbox and replace with your code.
' MsgBox wdDoc2.Name
RTF_Files_CntrlG
'You can save it, if you like, here it's not saved
wdDoc2.Close wdDoNotSaveChanges
sFile = Dir
Loop
End Sub
Sub RTF_Files_CntrlG()
Dim countlen As Long
Dim nom As String
Dim strName As String
Dim wdDoc2 As Document

'
' RTF_Files_CntrlG Macro
' Macro recorded 4/5/2007 by Kristy Patteson
'
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^b"
.Replacement.Text = "^m"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^d"
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
If ActiveWindow.View.SplitSpecial <> wdPaneNone Then
ActiveWindow.Panes(2).Close
End If
If ActiveWindow.ActivePane.View.Type = wdNormalView Or ActiveWindow. _
ActivePane.View.Type = wdOutlineView Then
ActiveWindow.ActivePane.View.Type = wdPrintView
End If
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
Selection.MoveRight Unit:=wdCharacter, Count:=2, Extend:=wdExtend
Selection.Delete Unit:=wdCharacter, Count:=1
If Selection.HeaderFooter.IsHeader = True Then
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageFooter
Else
ActiveWindow.ActivePane.View.SeekView = wdSeekCurrentPageHeader
End If
Selection.Delete Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.MoveLeft Unit:=wdCharacter, Count:=1
Selection.MoveRight Unit:=wdCharacter, Count:=1
Selection.Delete Unit:=wdCharacter, Count:=1
ActiveWindow.ActivePane.View.SeekView = wdSeekMainDocument
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
With Selection.Find
.Text = "^m"
.Replacement.Text = "^p"
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll
With ActiveDocument.Styles(wdStyleNormal).Font
If .NameFarEast = .NameAscii Then
.NameAscii = ""
End If
.NameFarEast = ""
End With
With ActiveDocument.PageSetup
.LineNumbering.Active = False
.Orientation = wdOrientPortrait
.TopMargin = InchesToPoints(0.25)
.BottomMargin = InchesToPoints(0.25)
.LeftMargin = InchesToPoints(0.25)
.RightMargin = InchesToPoints(0.25)
.Gutter = InchesToPoints(0)
.HeaderDistance = InchesToPoints(0.5)
.FooterDistance = InchesToPoints(0.25)
.PageWidth = InchesToPoints(8.5)
.PageHeight = InchesToPoints(11)
.FirstPageTray = wdPrinterDefaultBin
.OtherPagesTray = wdPrinterDefaultBin
.SectionStart = wdSectionNewPage
.OddAndEvenPagesHeaderFooter = False
.DifferentFirstPageHeaderFooter = False
.VerticalAlignment = wdAlignVerticalTop
.SuppressEndnotes = False
.MirrorMargins = False
.TwoPagesOnOne = False
.BookFoldPrinting = False
.BookFoldRevPrinting = False
.BookFoldPrintingSheets = 1
.GutterPos = wdGutterPosLeft
countlen = Len(ActiveDocument.Name)
nom = Left(ActiveDocument.Name, countlen - 4)
ThisDocument.SaveAs FileName:="f:\Temp\rtf\" & nom & ".doc"
'wdDoc2.Close wdSaveChanges
End With
End Sub

[maryidahosas]

Lucas,
I ran it, changing only the directory path. It did the same thing as before, it looped and created all the files, but they are all blank. I'm at a loss as to why. Any pther thoughts?

Mary

P.S. Thanks for all your help!

[lucas]

Well our first objective was to get it to loop through the files...rtf.
Does your code work on one file....?
could you post one of the rtf files for testing and tell us what you are trying to do to them before you save them as .doc files?

[fumei]

Yes. Please post a sample rtf. For one thing, the code that actions the RTF file can be cut down by 90% - that is, 90% of the code is blather.

This is not a comment on your coding ability. Recorded macros almost always contain a huge amount of extraneous crap.

If I am folllowing correctly, what you are doing is:

- changing Section breaks to manual page breaks
- deleting all Fields (replacing fields with "")
- doing something in the header/footer
- changing manual page breaks into paragraph marks

[mdmackillop]

Hi Mary,
When you post code, please select it and click the VBA button to format it, making it more readable.
Regards
MD