Option Explicit
Public FSO As Object 'a FileSystemObject
Public oFolder As Object 'the folder object
Public oSubFolder As Object 'the subfolders collection
Public oFiles As Object 'the files object
Public i As Long
 
Sub Main()
' Minimise screen flickering
Application.ScreenUpdating = False
Dim StrFolder As String
' Browse for the starting folder
StrFolder = GetTopFolder
If StrFolder = "" Then Exit Sub
' Search the top-level folder
Call GetFolder(StrFolder & "\")
' Search the subfolders for more files
Call SearchSubFolders(StrFolder)
' Return control of status bar to Word
Application.StatusBar = ""
' Restore screen updating
Application.ScreenUpdating = True
MsgBox i & " files processed.", vbOKOnly
End Sub
 
Function GetTopFolder() As String
GetTopFolder = ""
Set oFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder", 0)
If (Not oFolder Is Nothing) Then GetTopFolder = oFolder.Items.Item.Path
Set oFolder = Nothing
End Function
 
Sub SearchSubFolders(strStartPath As String)
If FSO Is Nothing Then
  Set FSO = CreateObject("scripting.filesystemobject")
End If
Set oFolder = FSO.GetFolder(strStartPath)
Set oSubFolder = oFolder.subfolders
For Each oFolder In oSubFolder
  Set oFiles = oFolder.Files
  ' Search the current folder
  Call GetFolder(oFolder.Path & "\")
  ' Call ourself to see if there are subfolders below
  SearchSubFolders oFolder.Path
Next
End Sub
 
Sub GetFolder(StrFolder As String)
Dim strFile As String
strFile = Dir(StrFolder & "*.txt")
' Process the files in the folder
While strFile <> ""
  ' Update the status bar is just to let us know where we are
  Application.StatusBar = StrFolder & strFile
  i = i + 1
  Call UpdateFile(StrFolder & strFile)
  Kill StrFolder & strFile
  strFile = Dir()
Wend
End Sub
 
Sub UpdateFile(strDoc As String)
Dim Doc As Document
' Open the document
Set Doc = Documents.Open(strDoc, AddToRecentFiles:=False, ReadOnly:=False, Format:=wdOpenFormatAuto, Visible:=False)
With Doc
  With .Range
    .Font.Name = "Calibri"
    .Font.Size = 12
    With .Find
      .Text = "</p></li> </ul> <p>"
      .Replacement.Text = "^p^p"
      .Execute Replace:=wdReplaceAll
      .Text = "</p></li> <li><p>"
      .Execute Replace:=wdReplaceAll
      .Text = "</p> <ul> <li><p>"
      .Execute Replace:=wdReplaceAll
      .Text = "</li> </ul> <p>"
      .Execute Replace:=wdReplaceAll
      .Text = "</p> <ul> <li>"
      .Execute Replace:=wdReplaceAll
      .Text = "</p> </div>"
      .Replacement.Text = " "
      .Text = "</p> <p>"
      .Replacement.Text = "^p^p"
      .Execute Replace:=wdReplaceAll
      .Text = "</p>"
      .Execute Replace:=wdReplaceAll
      .Text = "</em>"
      .Replacement.Text = ""
      .Execute Replace:=wdReplaceAll
      .Text = "<em>"
      .Execute Replace:=wdReplaceAll
      .Text = "</strong>"
      .Execute Replace:=wdReplaceAll
      .Text = "<strong>"
      .Execute Replace:=wdReplaceAll
      .Text = "<a"
      .Execute Replace:=wdReplaceAll
      .Text = "</a></strong>"
      .Execute Replace:=wdReplaceAll
      .Text = "href=*>"
      .Execute Replace:=wdReplaceAll
      .Text = "<div class=""md""><p>"
      .Replacement.Text = "^p^p"
      .Execute Replace:=wdReplaceAll
      .Text = "'"
      .Replacement.Text = "'"
      .Execute Replace:=wdReplaceAll
      .Text = "&quot;"
      .Replacement.Text = "”"
      .Execute Replace:=wdReplaceAll
    End With
  End With
  .SaveAs FileName:=Split(strDoc, ".txt")(0) & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
  .Close SaveChanges:=True
End With
' Let Word do its housekeeping
DoEvents
Set Doc = Nothing
End Sub