Function BrowseFolder(Optional OpenAt As Variant) As Variant
    Dim ShellApplication As Object
    Set ShellApplication = CreateObject("Shell.Application").BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
    On Error Resume Next
    BrowseFolder = ShellApplication.self.Path
    Set ShellApplication = Nothing


    Select Case Mid(BrowseFolder, 2, 1)
        Case Is = ":"
        If Left(BrowseFolder, 1) = ":" Then GoTo err1
        Case Is = "\"
        If Not Left(BrowseFolder, 1) = "\" Then GoTo err1
        Case Else
        GoTo err1
    End Select
Exit Function
err1:
BrowseFolder = False
End Function

Private Sub CommandButton1_Click()





    Dim Response As Variant
    Response = BrowseFolder
    
    Dim oFolder As Object
    Dim tFolder As Object
    Dim oFile As Object
    Dim strDocName As String
    Dim intPos As Integer
    Dim locFolder As String
    Dim fileType As String
    On Error Resume Next
    locFolder = Response
        
                fileType = "PDF"
    Application.ScreenUpdating = False
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set oFolder = fs.GetFolder(locFolder)
    Set tFolder = fs.CreateFolder(locFolder & "Converted")
    Set tFolder = fs.GetFolder(locFolder & "Converted")
    For Each oFile In oFolder.Files
        Dim d As Document
        Set d = Application.Documents.Open(oFile.Path)
        
        
        
        Selection.Delete Unit:=wdCharacter, Count:=1
    WordBasic.TogglePortrait Tab:=3, PaperSize:=0, TopMargin:="1.04", _
        BottomMargin:="1.04", LeftMargin:="1", RightMargin:="1", Gutter:="0", _
        PageWidth:="11", PageHeight:="8.5", Orientation:=1, FirstPage:=0, _
        OtherPages:=0, VertAlign:=0, ApplyPropsTo:=0, FacingPages:=0, _
        HeaderDistance:="0.5", FooterDistance:="0.5", SectionStart:=2, _
        OddAndEvenPages:=0, DifferentFirstPage:=0, Endnotes:=0, LineNum:=0, _
        StartingNum:=1, FromText:=wdAutoPosition, CountBy:=0, NumMode:=0, _
        TwoOnOne:=0, GutterPosition:=0, LayoutMode:=0, CharsLine:=41, LinesPage:= _
        36, CharPitch:=220, LinePitch:=360, DocFontName:="+Body", DocFontSize:=11 _
        , PageColumns:=1, TextFlow:=0, FirstPageOnLeft:=0, SectionType:=1, _
        FolioPrint:=0, ReverseFolio:=0, FolioPages:=1
    With Selection.PageSetup
        .LineNumbering.Active = False
        .Orientation = wdOrientLandscape
        .TopMargin = InchesToPoints(0.5)
        .BottomMargin = InchesToPoints(0.5)
        .LeftMargin = InchesToPoints(0.5)
        .RightMargin = InchesToPoints(0.5)
        .Gutter = InchesToPoints(0)
        .HeaderDistance = InchesToPoints(0.5)
        .FooterDistance = InchesToPoints(0.5)
        .PageWidth = InchesToPoints(11)
        .PageHeight = InchesToPoints(8.5)
        .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
    
    Selection.TypeParagraph
    Selection.TypeParagraph
    Selection.MoveUp Unit:=wdLine, Count:=2
    Selection.InlineShapes.AddPicture FileName:= _
        "t:\Logo Eng voice.PNG", _
        LinkToFile:=False, SaveWithDocument:=True
    Selection.MoveDown Unit:=wdLine, Count:=4
    Selection.MoveLeft Unit:=wdCharacter, Count:=9
    Selection.MoveRight Unit:=wdCharacter, Count:=31, Extend:=wdExtend
    Selection.Copy
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Dim myStoryRange As Range
    Selection.WholeStory
    Selection.Font.Size = 8
For Each myStoryRange In ActiveDocument.StoryRanges
    With myStoryRange.Find
        .Text = "****    ACCOUNT SUMMARY    ****"
        .Replacement.Text = "                         "
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With
    Do While Not (myStoryRange.NextStoryRange Is Nothing)
        Set myStoryRange = myStoryRange.NextStoryRange
        With myStoryRange.Find
            .Text = "findme"
            .Replacement.Text = ""
            .Wrap = wdFindContinue
            .Execute Replace:=wdReplaceAll
        End With
    Loop
Next myStoryRange
        
        strDocName = ActiveDocument.Name
        intPos = InStrRev(strDocName, ".")
        strDocName = Left(strDocName, intPos - 1)
        ChangeFileOpenDirectory tFolder
        Select Case fileType
               Case Is = "PDF"
            strDocName = strDocName & ".pdf"

            ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF
            
        End Select
        d.Close SaveChanges:=wdDoNotSaveChanges
        ChangeFileOpenDirectory oFolder
    Next oFile
    Application.ScreenUpdating = True





MsgBox "All files have been converted"

End Sub