John Croson's Blog Home: 04/01/2006 - 05/01/2006

Tuesday, April 04, 2006

Output MS Publisher to PRN files

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
      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:
   ' 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 & " 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"
   End With      
               Debug.Print "this is crap"
            End If
      End If
 End Sub