I needed a method to programatically check a series of directories for .pub and save as .prn for later batch processing to .pdf through Distiller. There were hundreds, and I just couldn't make myself do it by hand... After a little Googling, I found some useful code snippets from MS, and Google groups.
Comments and credits were left intact in the functions I borrowed, as well as my own. Hope someone finds this as useful as I did.
Option Explicit
Function GetFiles(strPath As String, _
dctDict As Scripting.Dictionary, _
Optional blnRecursive As Boolean) As Boolean
' This procedure returns all the files in a directory into
' a Dictionary object. If called recursively, it also returns
' all files in subfolders.
Dim fsoSysObj As Scripting.FileSystemObject
Dim fdrFolder As Scripting.Folder
Dim fdrSubFolder As Scripting.Folder
Dim filFile As Scripting.File
' Return new FileSystemObject.
Set fsoSysObj = New Scripting.FileSystemObject
On Error Resume Next
' Get folder.
Set fdrFolder = fsoSysObj.GetFolder(strPath)
If Err <> 0 Then
' Incorrect path.
GetFiles = False
GoTo GetFiles_End
End If
On Error GoTo 0
' Loop through Files collection, adding to dictionary.
For Each filFile In fdrFolder.Files
dctDict.Add filFile.Path, filFile.Path
Next filFile
' If Recursive flag is true, call recursively.
If blnRecursive Then
For Each fdrSubFolder In fdrFolder.SubFolders
GetFiles fdrSubFolder.Path, dctDict, True
Next fdrSubFolder
End If
' Return True if no error occurred.
GetFiles = True
GetFiles_End:
Exit Function
End Function
Function CountInString(ByVal strCountIn As String, ByVal strCountThis As String) As Long
Dim lngLoop As Long
Dim lngCount As Long
For lngLoop = 1 To Len(strCountIn)
If Mid$(strCountIn, lngLoop, Len(strCountThis)) = strCountThis Then
lngCount = lngCount + 1
End If
Next lngLoop
CountInString = lngCount
End Function
Function Dir_Make(S As String) As Boolean
' Makes a Directory, and each Branch if necessary.
' Example: Status = Dir_Make("C:\Dir1\Dir2\Dir3")
' Returns True if successful
' For Excel 2k due to Split() Function
' By: Dana DeLouis: d...@msn.com
' 6/7/99
Dim V As Variant
Dim j As Integer
Dim sDir As String
Dim drv As String
Dim fs As Object
Const vblf2 = vbLf & vbLf
'// Check for invalid Windows Characters...
S = Trim(S)
j = 0
j = j + InStr(1, S, "/")
j = j + InStr(3, S, ":") ' the ":" in C: j = j + InStr(1, S, "*")
j = j + InStr(1, S, "?")
j = j + InStr(1, S, ">")
j = j + InStr(1, S, "<") j = j + InStr(1, S, "|")
j = j + InStr(1, S, """")
If j > 0 Then
MsgBox "Folder " & S & vbLf & "has invalid Characters / : * ? < > |"
Exit Function
End If
'//
Set fs = CreateObject("Scripting.FileSystemObject")
With fs
drv = .GetDriveName(S) & Application.PathSeparator ' ie C:
'// Valid Drive? (as in A:\, C:\, D:\ ...etc)
If Not .DriveExists(drv) Then
MsgBox "Drive letter " &amp; drv & " not valid !" & vblf2 & S
Exit Function ' ->False
End If
'// Is Drive Ready (as in no Floppy in A:)?
If Not .GetDrive(drv).IsReady Then
MsgBox "Drive " & drv & " is not Ready !" & vblf2 & S
Exit Function ' ->False
End If
'// Unable if CD-Rom
If .GetDrive(drv).DriveType = 4 Then
MsgBox "Unable: " & drv & " is a CD-ROM !" & vblf2 & S
Exit Function ' ->False
End If
'// Break apart string s
V = Split(Trim(S), "\")
'// First test each branch for a File with no Extension!
sDir = drv
For j = 1 To UBound(V)
sDir = .BuildPath(RTrim$(sDir), V(j))
If .FileExists(sDir) Then
MsgBox "Unable because: " & vbLf & sDir & vblf2 & " ...is a File!"
Exit Function ' ->False
ElseIf Not .FolderExists(sDir) Then
Exit For ' Does not exist..No need to continue
End If
Next j
' Everything looks Ok, so make Directories
sDir = drv
For j = 1 To UBound(V)
sDir = .BuildPath(RTrim$(sDir), V(j))
If Not .FolderExists(sDir) Then .CreateFolder sDir
Next j
End With
Set fs = Nothing
Dir_Make = True
End Function
Sub TestGetFiles()
' Call to test GetFiles function.
Dim strPub As String
Dim dctDict As Scripting.Dictionary
Dim varItem As Variant
Dim strSrcPath As String
Dim strOutPath As String
Dim intHCnt As Integer
Dim intOutPos As Integer
Dim intPathCnt As Integer
Dim AppPub As Application
Dim DocPub As Document
Dim strDestPath As String
Dim strFile As String
Dim strName As String
Dim intEnd As Integer
Dim intPos As Integer
Dim strFinalOutPath As String
strDestPath = "e:\lol\out\"
strSrcPath = "e:\lol\publisher\"
strPub = "pub"
' Create new dictionary.
Set dctDict = New Scripting.Dictionary
' Call recursively, return files into Dictionary object.
If GetFiles(strSrcPath, dctDict, True) Then
Set AppPub = New Publisher.Application
' Print items in dictionary.
For Each varItem In dctDict
'check to see if this is a publisher file
If Right(varItem, 3) = strPub Then
' strip out the full filename
intPos = InStrRev(varItem, "\", , vbTextCompare)
' increment the counter to not swallow our "\"
intPos = intPos + 1
' and get our filename
strFile = Mid(varItem, intPos)
' now strip off the .pub extension
intEnd = Len(strFile) - 4
strName = Left(strFile, intEnd)
intOutPos = InStr(18, varItem, "\", 1)
intHCnt = CountInString(varItem, "\")
If intHCnt > 3 Then
intPathCnt = intOutPos - 17
strOutPath = Mid(varItem, 18, intPathCnt)
Dir_Make (strDestPath & strOutPath)
End If
' consider using a replace function to get rid of
' commas and periods
Set DocPub = AppPub.Open(varItem)
AppPub.ActiveWindow.Visible = True
strFinalOutPath = strDestPath & strOutPath
'set it to lower case
strName = LCase(strName)
strName = Replace(strName, ",", "_")
strName = Replace(strName, "&", "_and_")
With DocPub
.ActivePrinter = "Acrobat Distiller"
.PrintOut _
PrintToFile:=strFinalOutPath & strName & ".prn"
.Close
End With
Else
Debug.Print "this is crap"
End If
Next
End If
End Sub
