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

Sub PrintToPDFCreator(sPDFName As String, _
                      sPDFPath As String, _
                      oDoc As Document, _
                      Optional sMasterPass As String, _
                      Optional sUserPass As String, _
                      Optional bNoCopy As Boolean, _
                      Optional bNoPrint As Boolean, _
                      Optional bNoEdit As Boolean)
Dim pdfjob As Object
Dim sPrinter As String
Dim iCopy As Integer, iPrint As Integer, iEdit As Integer

    If bNoCopy Then iCopy = 1 Else iCopy = 0
    If bNoPrint Then iPrint = 1 Else iPrint = 0
    If bNoEdit Then iEdit = 1 Else iEdit = 0

    'Change active printer to PDFCreator
    With Dialogs(wdDialogFilePrintSetup)
        sPrinter = .Printer
        .Printer = "PDFCreator"
        .DoNotSetAsSysDefault = True
        .Execute
    End With

    Set pdfjob = CreateObject("PDFCreator.clsPDFCreator")

    With pdfjob
        If .cStart("/NoProcessingAtStartup") = False Then
            GoTo err_Handler
        End If

        .cStart "/NoProcessingAtStartup"
        .cOption("UseAutosave") = 1
        .cOption("UseAutosaveDirectory") = 1
        .cOption("AutosaveDirectory") = sPDFPath
        .cOption("AutosaveFilename") = sPDFName
        .cOption("AutosaveFormat") = 0        ' 0 = PDF

        If Not sMasterPass = vbNullString Then

            'The following are required to set security of any kind
            .cOption("PDFUseSecurity") = 1
            .cOption("PDFOwnerPass") = 1
            .cOption("PDFOwnerPasswordString") = sMasterPass

            'To set individual security options
            .cOption("PDFDisallowCopy") = iCopy
            .cOption("PDFDisallowModifyContents") = iEdit
            .cOption("PDFDisallowPrinting") = iPrint

            'To force a user to enter a password before opening
            .cOption("PDFUserPass") = 1
            .cOption("PDFUserPasswordString") = sUserPass
            'To change to High encryption
            .cOption("PDFHighEncryption") = 1
        End If

        .cClearCache
    End With

    'Print the document to PDF
    oDoc.PrintOut

    'Wait until the print job has entered the print queue
    Do Until pdfjob.cCountOfPrintjobs = 1
        DoEvents
    Loop
    pdfjob.cPrinterStop = False

    'Wait until PDF creator is finished then release the objects
    Do Until pdfjob.cCountOfPrintjobs = 0
        DoEvents
    Loop
    pdfjob.cClose
    'Restore the original printer
    With Dialogs(wdDialogFilePrintSetup)
        .Printer = sPrinter
        .Execute
    End With
lbl_Exit:
    Set pdfjob = Nothing
    Exit Sub
err_Handler:
    MsgBox "Unable to initialize PDFCreator." & vbCr & vbCr & _
           "This may be an indication that the PDF application has become corrupted, " & _
           "or its spooler blocked by AV software." & vbCr & vbCr & _
           "Re-installing PDF Creator may restore normal working."
    GoTo lbl_Exit
End Sub

ActiveDocument.ExportAsFixedFormat OutputFileName:=strDocName, ExportFormat:=wdExportFormatPDF

PrintToPDFCreator strDocName, tFolder, ActiveDocument