# VBA to Combine Differently Formatted Word Files into 1 while Preserving Layouts



## agent_maxine (Jan 4, 2018)

Dear Mr. Excel,

Would like to request your kind assistance on my codes below... I have codes that will allow me to select multiple files and combine them into 1 Word (then exports into 1 PDF). Problem is:

*Headers/Footers:* The header/footer from the first file is used for the entire combined file.
*Font Types/Sizes/Layouts:* It seems to use the Word default template's font type/sizes and disregards the types used in original Word documents (even the first file).

How can I make it so that the Combined File keeps the formatting of individual documents? Codes were adopted from this page:
https://www.datanumen.com/blogs/2-ways-quickly-merge-multiple-word-documents-one-via-vba/


```
Sub Combine_Selected_Documents()

Dim dlgFile As FileDialog
Dim nTotalFiles As Integer, nEachSelectedFile As Integer
Dim strFolder As String, myFolder As folder

Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")

Set dlgFile = Application.FileDialog(msoFileDialogFilePicker)

With dlgFile
    .AllowMultiSelect = True
    If .Show <> -1 Then
        Exit Sub
    Else
        strFolder = .SelectedItems(1) & Application.PathSeparator
        nTotalFiles = .SelectedItems.Count
    End If
End With

'Add code to check if PDF file exists, if no Word files were selected, if it works with different Word Document names, etc.

Dim myArr
myArr = Split(strFolder, "\")
strFolder = myArr(0)
For i = 1 To UBound(myArr) - 2
    strFolder = strFolder & "\" & myArr(i)
Next i
strFolder = strFolder & "\"
'MsgBox strFolder

Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
Dim objDoc As Word.Document
Set objDoc = objWord.Documents.Add
objWord.Visible = False 'Temporary
Set objSelection = objWord.Selection
'objSelection.TypeText ("This is my text in Word Document using Excel")

For nEachSelectedFile = 1 To nTotalFiles
objSelection.InsertFile dlgFile.SelectedItems.Item(nEachSelectedFile)
   
    If nEachSelectedFile < nTotalFiles Then
        objSelection.InsertBreak Type:=wdSectionBreakNextPage
        
    Else
        If nEachSelectedFile = nTotalFiles Then
        objDoc.ExportAsFixedFormat OutputFileName:=strFolder & "Forms.pdf", ExportFormat:=wdExportFormatPDF ', OpenafterPublish:=OpenafterPublish
        objDoc.SaveAs2 (strFolder & "Forms Combined.docx")
        objDoc.Close
        'objWord.Quit
        
        Exit Sub
        End If
    End If
Next nEachSelectedFile

MsgBox "All the Selected Documents have been Combined into 1 PDF File."

End Sub
```


----------



## Macropod (Jan 4, 2018)

The code to do that is rather more complex than what you presently have. Not only do you need to transfer the body content of all the source documents to a new file before doing the PDF conversions, but you also need to transfer the page layouts and header/footer structure. Try the following:

```
Sub MergeDocuments()
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strTgt As String
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set wdDocTgt = ActiveDocument: strTgt = ActiveDocument.FullName
strFile = Dir(strFolder & "\*.docx", 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
          End With
        Next
        For Each HdFt In .Footers
          With HdFt
            .LinkToPrevious = False
            .Range.Text = vbNullString
          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
```


----------



## agent_maxine (Jan 5, 2018)

Hi Paul,

Yes I did actually try your codes before (found it on VBA Express I believe). It seems to use an Active Document though, and I didn't know how to tweak it so that it doesn't rely on having a document open.
How can the codes be adopted so that it works when no Word files are open?

Thank you!


----------



## Macropod (Jan 5, 2018)

To combine documents, you must have a document they can be combined in. Since, if you're running the code from Word, you must also have a document open to run the macro, it seems to make sense for that to be the starting document.


----------



## agent_maxine (Jan 5, 2018)

Sorry, should have clarified -- I am running the macro from Excel, not Word...

**Edit:* I am hoping to run the codes from an Excel system that decides which files should be generated (done via separate set of codes). I am now working on piece where the files generated from the previous step are now combined into 1 Word (then to 1 PDF).


----------



## Macropod (Jan 5, 2018)

In that case, try something along the lines of:

```
Sub MergeDocuments()
'Note: This code required a reference to Word, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String, strTgt As String
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application: wdApp.Visible = True
Dim wdDocTgt As Word.Document, wdDocSrc As Word.Document, HdFt As Word.HeaderFooter
Set wdDocTgt = wdApp.Documents.Add
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDocSrc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDocTgt
    If Len(.Range.Text) > 1 Then
      .Characters.Last.InsertBefore vbCr
      .Characters.Last.InsertBreak (wdSectionBreakNextPage)
    End If
    With .Sections.Last
      For Each HdFt In .Headers
        With HdFt
          .LinkToPrevious = False
          .Range.Text = vbNullString
        End With
      Next
      For Each HdFt In .Footers
        With HdFt
          .LinkToPrevious = False
          .Range.Text = vbNullString
        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
  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
wdApp.Quit
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing: Set wdApp= Nothing
Application.ScreenUpdating = True
End Sub

Sub LayoutTransfer(wdDocTgt As Word.Document, wdDocSrc As Word.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
```
As for your last post's edit, that means modifying the code further, so it only processes the designated files - presumably without the need for a folder/file selector, too.


----------



## agent_maxine (Jan 5, 2018)

I'm getting the following error on this line (Line 12 from the Top).

*Run-Time Error '438': Object doesn't support this property or method.*

```
If Len(.Text) > 1 Then
```

*Quick Note:* I switched the order slightly after seeing the "Duplicate Declaration in Current Scope" message 

```
Dim wdApp As New Word.Application, wdDocTgt As Word.Document, wdDocSrc As Word.Document, HdFt As Word.HeaderFooter
Set wdDocTgt = wdApp.Documents.Add
```


----------



## Macropod (Jan 6, 2018)

agent_maxine said:


> I'm getting the following error on this line (Line 12 from the Top).
> 
> *Run-Time Error '438': Object doesn't support this property or method.*




```
If Len(.Text) > 1 Then
```
Oops, change that to:

```
If Len(.Range.Text) > 1 Then
```

Original code corrected.


----------



## agent_maxine (Jan 6, 2018)

Hmm now I'm getting this...

*Run-Time Error '4218': Type Mismatch.
*


> .Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText


----------



## Macropod (Jan 6, 2018)

I've re-tested the code and I'm not getting that error. I suggest you:
1. Close Excel and Word
2. Use the Task Manager to kill any orphaned Excel/Word sessions
3. Re-start Excel & open your workbook
4. Replace the existing code with the updated code in post 6 (Note: I've added wdApp.Visible = True so you shouldn't get an orphaned Word session if a crash occurs)
5. Re-run the code.


----------



## agent_maxine (Jan 4, 2018)

Dear Mr. Excel,

Would like to request your kind assistance on my codes below... I have codes that will allow me to select multiple files and combine them into 1 Word (then exports into 1 PDF). Problem is:

*Headers/Footers:* The header/footer from the first file is used for the entire combined file.
*Font Types/Sizes/Layouts:* It seems to use the Word default template's font type/sizes and disregards the types used in original Word documents (even the first file).

How can I make it so that the Combined File keeps the formatting of individual documents? Codes were adopted from this page:
https://www.datanumen.com/blogs/2-ways-quickly-merge-multiple-word-documents-one-via-vba/


```
Sub Combine_Selected_Documents()

Dim dlgFile As FileDialog
Dim nTotalFiles As Integer, nEachSelectedFile As Integer
Dim strFolder As String, myFolder As folder

Dim fso As FileSystemObject
Set fso = CreateObject("Scripting.FileSystemObject")

Set dlgFile = Application.FileDialog(msoFileDialogFilePicker)

With dlgFile
    .AllowMultiSelect = True
    If .Show <> -1 Then
        Exit Sub
    Else
        strFolder = .SelectedItems(1) & Application.PathSeparator
        nTotalFiles = .SelectedItems.Count
    End If
End With

'Add code to check if PDF file exists, if no Word files were selected, if it works with different Word Document names, etc.

Dim myArr
myArr = Split(strFolder, "\")
strFolder = myArr(0)
For i = 1 To UBound(myArr) - 2
    strFolder = strFolder & "\" & myArr(i)
Next i
strFolder = strFolder & "\"
'MsgBox strFolder

Dim objWord As Word.Application
Set objWord = CreateObject("Word.Application")
Dim objDoc As Word.Document
Set objDoc = objWord.Documents.Add
objWord.Visible = False 'Temporary
Set objSelection = objWord.Selection
'objSelection.TypeText ("This is my text in Word Document using Excel")

For nEachSelectedFile = 1 To nTotalFiles
objSelection.InsertFile dlgFile.SelectedItems.Item(nEachSelectedFile)
   
    If nEachSelectedFile < nTotalFiles Then
        objSelection.InsertBreak Type:=wdSectionBreakNextPage
        
    Else
        If nEachSelectedFile = nTotalFiles Then
        objDoc.ExportAsFixedFormat OutputFileName:=strFolder & "Forms.pdf", ExportFormat:=wdExportFormatPDF ', OpenafterPublish:=OpenafterPublish
        objDoc.SaveAs2 (strFolder & "Forms Combined.docx")
        objDoc.Close
        'objWord.Quit
        
        Exit Sub
        End If
    End If
Next nEachSelectedFile

MsgBox "All the Selected Documents have been Combined into 1 PDF File."

End Sub
```


----------



## agent_maxine (Jan 6, 2018)

Thank you. I did kill all Excel/Word sessions and the codes ran without any error. Looking at the merged file, I have noticed the following:

Formatting Details that appear to be preserved --> Thank you!
- Headers 
- Page Margins

Formatting Details that need fixing:
- *Line Spacing*: Source documents have 0pt After, Single spacing. The newly merged document has 8pt After, 1.08 Multiple Spacing, which seems to be default for my blank/new Word file. How do I tell Word to use 0pt After, Single spacing for the new document? Or keep the source spacing? (I can certainly update my own Normal Template, but this will need to be the same for other users as well).
- *Font Types:* Some keep the source types and some don't.
- *Paragraph Alignment:* Some keep the source types (Justified) and some don't. 
- *Page/Section Breaks:* Some documents have been pasted on the same page (even though it has Section Break). How do I ensure each document will be pasted on the next page?
- *Footers:* Preserved, with the exception of Page #s . Some original documents were 2 pages and had "Page # of 2" embedded. Now the page numbers are wonky (e.g. "Page 6 of 3", then a few pages down I see "Page 10 of 2", etc.)

Apologies for being a pain; these documents are filed and thus the formatting must be preserved. I have no clue why some of the selected files preserve the formatting and others don't :\
Thank you...


----------



## agent_maxine (Jan 7, 2018)

In order to tackle the items to fix, was thinking -- 

*1. Line Spacing/Font Types/Paragraph Alignment Issues:* During the LayoutTransfer Sub, would I be able to add something like this after With ... PageSetup lines?
(I'm getting Expression error so I don't think they're quite right...)

```
With wdDocTgt.Sections.Last.Paragraph
    .LineSpacing = Single
    .SpaceAfter = 0pt
    .Alignment = Justify
    .FontStyle = Times New Roman
    .FontSize = 10pt
End With
```

*2. Page # for Footers:* I tried adding a Page # property... getting a "Value out of range" error...

```
Dim lPages As Integer
With wdDocSrc.Sections.Last.PageSetup
lPages = .LinesPage

With wdDocTgt.Sections.Last.PageSetup
.LinesPage = lPages
End With
```


----------



## Macropod (Jan 7, 2018)

Your formatting inconsistencies in the output are probably due to either:
1. The source documents being created by people/processes that didn't respect the Style definitions of the paragraphs concerned; and/or
2. Being defined differently from the template and/or each other.
Using .Copy & .PasteAndFormat wdFormatOriginalFormatting instead of the .FormattedText method will probably overcome most of the issues you're having with Line/Paragraph Spacing, Fonts, & Paragraph Alignment. However, it also creates other problems, including breaking anything related to references based on Style Definitions (e.g. Tables of Contents, Caption references, StyleRef fields).

Regarding the page #s , there really isn't anything that can be done about that without investing a lot of coding effort in analysing all of the field coding & settings for each header/footer, then figuring out how to preserve that in the combined document.

Regarding the Section breaks, that suggests the source documents have their own 'continuous' Section breaks and Word is having trouble respecting the 'next page' Section breaks that are required to achieve the desired outcome. Short of deleting the 'continuous' Section breaks in the source documents, there's not a lot that can be done about that.

Given the above, you may need to invest in software like Adobe Acrobat Pro and use that to combine the individual PDFs after Word has converted them to that format. That way, issues regarding Line/Paragraph Spacing, Fonts, & Paragraph Alignment, Section breaks & page #s  simply don't arise.


----------



## agent_maxine (Jan 7, 2018)

I agree with your conclusions... I did try to change the formatting of source documents for testing but the end result was the same.
Initially my approach was to convert every Word file in a folder into individual PDFs [https://www.datanumen.com/blogs/3-macro-ways-quickly-convert-word-documents-pdf-files/], then merge them into 1... but kept getting this:
*Run-Time Error '429': ActiveX component can't create object*


> Set objDoc = Documents.Open(FileName:=strFolder & strFile)



I do have Adobe Pro but most users have Nitro as PDF software. I have yet to find a set of codes that combine PDFs into 1 using Nitro :\


```
Sub BatchConvertDocxToPDF()
  Dim objDoc As Document
  Dim strFile As String, strFolder As String
 
  'Initialization
  strFolder = "C:\Users\Desktop\Test\"
  strFile = Dir(strFolder & "*.docx", vbNormal)
 
  'Precess each file in the file folder and convert them to pdf.
  While strFile <> ""
    Set objDoc = Documents.Open(FileName:=strFolder & strFile)
 
    objDoc.ExportAsFixedFormat OutputFileName:=Replace(objDoc.FullName, ".docx", ".pdf"), _
      ExportFormat:=wdExportFormatPDF, OpenAfterExport:=False, OptimizeFor:=wdExportOptimizeForPrint, _
      Range:=wdExportAllDocument, Item:=wdExportDocumentContent
 
    objDoc.Close
    strFile = Dir()
  Wend
End Sub
```


----------



## Macropod (Jan 7, 2018)

Try:

```
Sub BatchConvertDocsToPDF()
'Note: This code required a reference to Word, via Tools|References in the VBE.
Application.ScreenUpdating = False
Dim strFolder As String, strFile As String
strFolder = GetFolder: If strFolder = "" Then Exit Sub
Dim wdApp As New Word.Application, wdDoc As Word.Document: wdApp.Visible = True
strFile = Dir(strFolder & "\*.doc", vbNormal)
While strFile <> ""
  Set wdDoc = wdApp.Documents.Open(Filename:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
  With wdDoc
    .SaveAs Filename:=strFolder & "\" & Split(strFile, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
    .Close SaveChanges:=False
  End With
  strFile = Dir()
Wend
wdApp.Quit
Set wdDoc = Nothing: Set wdApp = 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
```


----------



## agent_maxine (Jan 7, 2018)

Actually, am wondering again...


> Using .Copy & .PasteAndFormat wdFormatOriginalFormatting instead of  the .FormattedText method will probably overcome most of the issues  you're having with Line/Paragraph Spacing, Fonts, & Paragraph  Alignment. However, it also creates other problems, including breaking  anything related to references based on Style Definitions (e.g. Tables  of Contents, Caption references, StyleRef fields).



I could probably use the earlier codes for the set of Word Docs without any Style Definitions. How would I go about changing the ".FormattedText" method to ".Copy & .PasteAndFormat wdFormatOriginalFormatting" method?


----------



## agent_maxine (Jan 7, 2018)

Macropod said:


> Try:
> 
> ```
> Sub BatchConvertDocsToPDF()
> ...



I'm getting a *Run-Time Error '438': Object doesn't support this property or method* 

```
.SaveAs FileName:=strFolder & "\" & Split(strFile, .doc)(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
```


----------



## Macropod (Jan 7, 2018)

It's the little things ...

Change:

```
.SaveAs Filename:=strFolder & "\" & Split(strFile, .doc)(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
```
to:

```
.SaveAs Filename:=strFolder & "\" & Split(strFile, ".doc")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
```


----------



## agent_maxine (Jan 7, 2018)

Wow, it worked like a charm! Also found this nifty codes and now it combines everything in a second [http://www.vbaexpress.com/forum/sho...-PDF-files-in-a-folder-using-adobe-acrobat-X]
The next step is to convince everyone to get the Adobe Pro... Thanks so much again :D


----------

