Quote:
Originally Posted by macropod
If you checked the code line on which the error occurs, you'd see that:
Call UpdateDocuments(CStr(Split(StrFolds, vbCr)(i)))
is highlighted.
Fairly obviously, I'd have thought, for consistency with the rest of the code you'd need to change that to:
Call CombineDocuments(CStr(Split(StrFolds, vbCr)(i)))
|
I did change that now and the error with compiling is gone, but theres a new error:
runtime error '4248'
this command isn't available, because no document is opened.
It happens when I try running the makro in one of the subfolders.
If I ask him to debug he's marking this in yellow:
Set wdDocTgt = ActiveDocument
(you'll find it close under Sub CombineDocuments)
He's still creating a Document, but it's empty.
If I run the makro on my topfolder it's getting a different error:
runtime error '5937'
the content can't be copied between these two areas
If I ask him to debug he's marking this in yellow:
.Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
(you'll find it in the middle of the Sub CombineDocuments)
What do I have to change?
Here's the changed code for you
Thanks fro the help again.
Code:
Dim FSO As Object, oFolder As Object, StrFolds As String Sub Main() Dim TopLevelFolder As String, TheFolders As Variant, aFolder As Variant, i As Long TopLevelFolder = GetFolder StrFolds = vbCr & TopLevelFolder If TopLevelFolder = "" Then Exit Sub 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 CombineDocuments(CStr(Split(StrFolds, vbCr)(i))) Next End Sub 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 Sub CombineDocuments(oFolder As String) Application.ScreenUpdating = False Dim strFolder As String, strFile As String, strTgt As String Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter strFolder = oFolder Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName strFile = Dir(strFolder & "\*.doc", vbNormal) While strFile <> "" If strFolder & strFile <> strTgt Then Set wdDocSrc = Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False) With wdDocTgt .Characters.Last.InsertBefore vbCr .Characters.Last.InsertBreak (wdSectionBreakNextPage) With .Sections.Last For Each HdFt In .Headers With HdFt .LinkToPrevious = False .Range.Text = vbNullString .PageNumbers.RestartNumberingAtSection = True .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber End With Next For Each HdFt In .Footers With HdFt .LinkToPrevious = False .Range.Text = vbNullString .PageNumbers.RestartNumberingAtSection = True .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber End With Next End With Call LayoutTransfer(wdDocTgt, wdDocSrc) .Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText With .Sections.Last For Each HdFt In .Headers With HdFt .Range.FormattedText = wdDocSrc.Sections.Last.Headers(.Index).Range.FormattedText .Range.Characters.Last.Delete End With Next For Each HdFt In .Footers With HdFt .Range.FormattedText = wdDocSrc.Sections.Last.Footers(.Index).Range.FormattedText .Range.Characters.Last.Delete End With Next End With End With wdDocSrc.Close SaveChanges:=False End If strFile = Dir() Wend With wdDocTgt ' Save & close the combined document .SaveAs FileName:=strFolder & "Forms.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False ' and/or: .SaveAs FileName:=strFolder & "Forms.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False .Close SaveChanges:=False End With Set wdDocSrc = Nothing: Set wdDocTgt = Nothing Application.ScreenUpdating = True End Sub Sub LayoutTransfer(wdDocTgt As Document, wdDocSrc As Document) Dim sPageHght As Single, sPageWdth As Single Dim sHeaderDist As Single, sFooterDist As Single Dim sTMargin As Single, sBMargin As Single Dim sLMargin As Single, sRMargin As Single Dim sGutter As Single, sGutterPos As Single Dim lPaperSize As Long, lGutterStyle As Long Dim lMirrorMargins As Long, lVerticalAlignment As Long Dim lScnStart As Long, lScnDir As Long Dim lOddEvenHdFt As Long, lDiffFirstHdFt As Long Dim bTwoPagesOnOne As Boolean, bBkFldPrnt As Boolean Dim bBkFldPrnShts As Boolean, bBkFldRevPrnt As Boolean Dim lOrientation As Long With wdDocSrc.Sections.Last.PageSetup lPaperSize = .PaperSize lGutterStyle = .GutterStyle lOrientation = .Orientation lMirrorMargins = .MirrorMargins lScnStart = .SectionStart lScnDir = .SectionDirection lOddEvenHdFt = .OddAndEvenPagesHeaderFooter lDiffFirstHdFt = .DifferentFirstPageHeaderFooter lVerticalAlignment = .VerticalAlignment sPageHght = .PageHeight sPageWdth = .PageWidth sTMargin = .TopMargin sBMargin = .BottomMargin sLMargin = .LeftMargin sRMargin = .RightMargin sGutter = .Gutter sGutterPos = .GutterPos sHeaderDist = .HeaderDistance sFooterDist = .FooterDistance bTwoPagesOnOne = .TwoPagesOnOne bBkFldPrnt = .BookFoldPrinting bBkFldPrnShts = .BookFoldPrintingSheets bBkFldRevPrnt = .BookFoldRevPrinting End With With wdDocTgt.Sections.Last.PageSetup .GutterStyle = lGutterStyle .MirrorMargins = lMirrorMargins .SectionStart = lScnStart .SectionDirection = lScnDir .OddAndEvenPagesHeaderFooter = lOddEvenHdFt .DifferentFirstPageHeaderFooter = lDiffFirstHdFt .VerticalAlignment = lVerticalAlignment .PageHeight = sPageHght .PageWidth = sPageWdth .TopMargin = sTMargin .BottomMargin = sBMargin .LeftMargin = sLMargin .RightMargin = sRMargin .Gutter = sGutter .GutterPos = sGutterPos .HeaderDistance = sHeaderDist .FooterDistance = sFooterDist .TwoPagesOnOne = bTwoPagesOnOne .BookFoldPrinting = bBkFldPrnt .BookFoldPrintingSheets = bBkFldPrnShts .BookFoldRevPrinting = bBkFldRevPrnt .PaperSize = lPaperSize .Orientation = lOrientation End With 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