Need VBA Code to Move MS Office Files to Different Folders and Place PDF Copies in Other Folders

' ConvertToPDFAndMove.vbs

'- Moves myfile.doc into Folder B 
'- Saves myfile.doc as myfile.PDF into Folder C 
'- Saves myfile.doc as myfile.PDF into Folder D 
'- Moves myfile.doc from Folder A into Folder E 
'- Stops when Folder A is empty; leaving user with view of 
'  the empty Folder A as confirmation all files were processed 

' In all cases, the various folders could be on different (mapped) network 
' drives, hence this needs to be coded to use the full filepath (windows 
' environment). 

' Also, while the above example is written showing .doc files, we can 
' expect .docx as well as Excel files in .xls, .xlsx, and .xlsm. 

Set objFSO = CreateObject("Scripting.FileSystemObject")

FolderA="c:\local\test\a"
FolderB="c:\local\test\b"
FolderC="c:\local\test\c"
FolderD="c:\local\test\d"
FolderE="c:\local\test\e"
arrFolders = Array(FolderB, FolderC, FolderD, FolderE)
ChkFolders

ChkFExt="DOC"
ProcessFolders objFSO.GetFolder(FolderA)

WScript.Quit

'-------------------------------------------------------------------------------
Sub ProcessFolders (folder)
Const OverwriteExisting = TRUE

Dim file, fname, srcfname, tgtfname, upext
For Each file in folder.files
	fname = file.name
	upext = UCase(objfso.GetExtensionName(fname))
	fbase = objfso.GetBaseName(fname)
	If upext = ChkFExt Then
		srcfname = FolderA & "\" & fname
		tgtfname = FolderB & "\" & fname
		'- Move file into Folder B 
		WScript.Echo "Moving " & FolderA & "\" & fname & " " & FolderB
		objFSO.MoveFile srcfname , tgtfname
'- Saves myfile.doc as myfile.PDF into Folder C 
		'Doc2PDF tgtfname
		WScript.Echo FolderB & "\" & fbase & ".pdf" , FolderC & "\", OverwriteExisting
		objFSO.CopyFile "Copying " & FolderB & "\" & fbase & ".pdf" , FolderC & "\", OverwriteExisting
'- Saves myfile.doc as myfile.PDF into Folder D 
		WScript.Echo FolderB & "\" & fbase & ".pdf" , FolderD & "\"
		objFSO.MoveFile "Moving " & FolderB & "\" & fbase & ".pdf" , FolderD & "\"
		'WScript.Quit
'- Moves myfile.doc from Folder A into Folder E.
'  ? myfile.doc was already moved to Folder B in prior step.
	End if
Next
End Sub

'-------------------------------------------------------------------------------
Function ChkFolders()
If Not objFSO.FolderExists(FolderA) Then
    WScript.Echo "Folder missing. Please create it: " & FolderA
		WScript.Quit
End If

' Create folders as needed
'arrFolders = Array(FolderB, FolderC, FolderD, FolderE)
For Each strFolder in arrFolders
    MakeFolder(strFolder)
Next
End Function

'-------------------------------------------------------------------------------
Function MakeFolder(cName)
If objFSO.FolderExists(cName) Then
    Set objFolder = objFSO.GetFolder(cName)
Else
		' Create Folder
		' Note: If the parent folder does not exist, and error occurs.
    'WScript.Echo "Folder missing: " & cName
		Set objFolder = objFSO.CreateFolder(cName)
End If
End Function

'-------------------------------------------------------------------------------
Sub Doc2PDF( myFile )
' This subroutine opens a Word document, then saves it as PDF, and closes Word.
' If the PDF file exists, it is overwritten.
' If Word was already active, the subroutine will leave the other document(s)
' alone and close only its "own" document.
'
' Requirements:
' This script requires the "Microsoft Save as PDF or XPS Add-in for 2007
' Microsoft Office programs", available at:
' http://www.microsoft.com/downloads/details.aspx?
'        familyid=4D951911-3E7E-4AE6-B059-A2E79ED87041&displaylang=en
'
' Written by Rob van der Woude
' http://www.robvanderwoude.com

    ' Standard housekeeping
    Dim objDoc, objFile, objFSO, objWord, strFile, strPDF

    Const wdFormatDocument                    =  0
    Const wdFormatDocument97                  =  0
    Const wdFormatDocumentDefault             = 16
    Const wdFormatDOSText                     =  4
    Const wdFormatDOSTextLineBreaks           =  5
    Const wdFormatEncodedText                 =  7
    Const wdFormatFilteredHTML                = 10
    Const wdFormatFlatXML                     = 19
    Const wdFormatFlatXMLMacroEnabled         = 20
    Const wdFormatFlatXMLTemplate             = 21
    Const wdFormatFlatXMLTemplateMacroEnabled = 22
    Const wdFormatHTML                        =  8
    Const wdFormatPDF                         = 17
    Const wdFormatRTF                         =  6
    Const wdFormatTemplate                    =  1
    Const wdFormatTemplate97                  =  1
    Const wdFormatText                        =  2
    Const wdFormatTextLineBreaks              =  3
    Const wdFormatUnicodeText                 =  7
    Const wdFormatWebArchive                  =  9
    Const wdFormatXML                         = 11
    Const wdFormatXMLDocument                 = 12
    Const wdFormatXMLDocumentMacroEnabled     = 13
    Const wdFormatXMLTemplate                 = 14
    Const wdFormatXMLTemplateMacroEnabled     = 15
    Const wdFormatXPS                         = 18
    Const wdFormatOfficeDocumentTemplate      = 23
    Const wdFormatMediaWiki                   = 24

    ' Create a File System object
    Set objFSO = CreateObject( "Scripting.FileSystemObject" )

    ' Create a Word object
    Set objWord = CreateObject( "Word.Application" )

    With objWord
        ' True: make Word visible; False: invisible
        .Visible = True

        ' Check if the Word document exists
        If objFSO.FileExists( myFile ) Then
            Set objFile = objFSO.GetFile( myFile )
            strFile = objFile.Path
        Else
            WScript.Echo "FILE OPEN ERROR: The file does not exist" & vbCrLf
            ' Close Word
            .Quit
            Exit Sub
        End If

        ' Build the fully qualified HTML file name
        strPDF = objFSO.BuildPath( objFile.ParentFolder, _
                 objFSO.GetBaseName( objFile ) & ".pdf" )

        ' Open the Word document
        .Documents.Open strFile

        ' Make the opened file the active document
        Set objDoc = .ActiveDocument

        ' Save as HTML
        objDoc.SaveAs strPDF, wdFormatPDF

        ' Close the active document
        objDoc.Close

        ' Close Word
        .Quit
    End With
End Sub

Select all Open in new window