模拟原始批量打印

Sub SearchAndPrint()
  Dim Counter As Integer
  Dim oEle As Element
  Dim oLevel As Level
  Dim LevelName As String
  Dim oAtt As Attachment
  Dim ee As ElementEnumerator
  Dim esc As ElementScanCriteria
  Dim oShape As ShapeElement
  Dim oAttach As Attachment
  Dim LNoAttach As Attachment 'Live Nested
  Dim oView As View
  Dim oFence As Fence
  Dim fso As Object
  Dim DatedFolder As String
  
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FolderExists("C:\Temp") Then
    fso.CreateFolder ("C:\Temp") 'Create Parent Directory if it doesn't exist
End If
DatedFolder = "C:\Temp" & Format(Now, "yyyy") & Format(Now, "mm") & Format(Now, "dd")
If Not fso.FolderExists(DatedFolder) Then
fso.CreateFolder (DatedFolder) 'Create dated Folder if it doesn't exist
End If
  Set oView = ActiveDesignFile.Views(1) 'Works ONLY with View 1
Counter = 0 'Counter used to avoid overwriting files if multiple sheets are found
Set esc = New ElementScanCriteria
esc.ExcludeAllTypes
esc.IncludeType msdElementTypeShape 'Only scans shapes
If ActiveModelReference.Attachments.Count = 0 Then 'Scans active drawing levels if no reference file is detected
Set ee = ActiveModelReference.Scan(esc)
Do While ee.MoveNext
Set oEle = ee.Current
If Not oEle.Level Is Nothing Then
    LevelName = oEle.Level.Name
     If LevelName = "D_BATCH_PLOT" Then
            Set oShape = oEle           'Pick Shape for fence if it resides on correct level
  Set oFence = ActiveDesignFile.Fence
  If oFence.IsDefined Then oFence.Undefine
  oFence.DefineFromElement oView, oShape
  Counter = Counter + 1
  PrintPDF  'Print to pdf using predetermined settings in public function
     End If
End If
Loop
End If
    For Each oAttach In ActiveModelReference.Attachments    'Scans Each Attachment in the active file
        If oAttach.Attachments.Count > 0 And oShape Is Nothing Then       'Checks for live nesting and proceeds if no shape is found
            For Each LNoAttach In oAttach.Attachments   'If nested attachments are found, they are also scanned
                Set ee = LNoAttach.Scan(esc)
            Do While ee.MoveNext And oShape Is Nothing 'Scanning Continues until shape is found
             Set oEle = ee.Current
                If Not oEle.Level Is Nothing Then
                    LevelName = oEle.Level.Name
                    If LevelName = "D_BATCH_PLOT" Then
                        Set oShape = oEle          'Pick Shape for fence if it resides on correct level
                         Set oFence = ActiveDesignFile.Fence
                        If oFence.IsDefined Then oFence.Undefine
                        oFence.DefineFromElement oView, oShape
                        Counter = Counter + 1
                        PrintPDF 'Print to pdf using predetermined settings in public function
                    End If
                End If
            Loop
            Next
        Else
             Set ee = oAttach.Scan(esc) 'If no live nesting is detected, scan direct reference levels
             Do While ee.MoveNext And oShape Is Nothing 'Until shape is found
             Set oEle = ee.Current
                If Not oEle.Level Is Nothing Then
                    LevelName = oEle.Level.Name
                    If LevelName = "D_BATCH_PLOT" Then
                        Set oShape = oEle         'Pick Shape for fence if it resides on correct level
                         Set oFence = ActiveDesignFile.Fence
                        If oFence.IsDefined Then oFence.Undefine
                        oFence.DefineFromElement oView, oShape
                        Counter = Counter + 1
                        PrintPDF 'Print to pdf using predetermined settings in public function
                    End If
                End If
            Loop
        End If
        Set oShape = Nothing 'Sets Shape to nothing in case addtional border reference files are attached
    Next
Call OpenFolder(DatedFolder)    'Opens or brings focus to dated folder
End Sub
' ---------------------------------------------------------------------
'   PrintPDF
'   Print using the pdf-gs.pltcfg
'   Print using defined fence, view 1, pen_txdot.tbl
'   Create a PDF document in a dated folder in c:\temp\
' ---------------------------------------------------------------------
Public Sub PrintPDF()
    '   Load the PLOTDLG application
    CadInputQueue.SendKeyin "mdl load plotdlg"
    Dim Path As String
        Path = GetDgnFileName(ActiveModelReference)
        Path = Replace(Path, ".dgn", "")
        '   Set the PDF print driver and pen table
        CadInputQueue.SendKeyin "$ print driver $(pw_workdir)\dms08053\pdf - gs.pltcfg; print pentable attach $(pw_workdir)\dms08052\pen_txdot.tbl"
        '   Print with Active Fence
        Dim oFence                          As Fence
        Set oFence = ActiveDesignFile.Fence
        If oFence.IsDefined Then
            CadInputQueue.SendKeyin "print boundary fence"
        Else
            Const ViewNum                   As Integer = 1
            CadInputQueue.SendKeyin "print boundary view " & CStr(ViewNum)
        End If
        'Const PaperSize As String = "11x17" '<--This is currently the only page size, so it has been commented out
        'CadInputQueue.SendKeyin "print papername " & PaperSize
        CadInputQueue.SendKeyin "print colormode color"
        CadInputQueue.SendKeyin "print maximize"
        '   Execute the print.  The PDF is sent to the dated folder in c:\temp
        Path = "C:\Temp" & Format(Now, "yyyy") & Format(Now, "mm") & Format(Now, "dd") & "" & Path & "(" & Counter & ").pdf"
        CadInputQueue.SendKeyin "print execute " & Path
End Sub
Public Function GetDgnFileName(ByVal modelRef As ModelReference) As String
    GetDgnFileName = vbNullString
    On Error GoTo err_GetDgnFileName
    GetDgnFileName = modelRef.DesignFile.Name
    Exit Function
err_GetDgnFileName:
    MsgBox "Error no. " & CStr(Err.Number) & ": " & Err.Description & vbNewLine & _
    "Caused by " & Err.Source, vbOKOnly Or vbExclamation, "Get DGN File Name Error"
End Function
Private Sub OpenFolder(strDirectory As String)
'DESCRIPTION: Open folder if not already open. Otherwise, activate the already opened window
'DEVELOPER: Ryan Wells (wellsr.com)
'INPUT: Pass the procedure a string representing the directory you want to open
Dim pID As Variant
Dim sh As Variant
On Error GoTo 102:
Set sh = CreateObject("shell.application")
For Each w In sh.Windows
    If w.Name = "Windows Explorer" Or w.Name = "File Explorer" Then
        If w.document.folder.self.Path = strDirectory Then
            'if already open, bring it front
            w.Visible = False
            w.Visible = True
            Exit Sub
        End If
    End If
Next
'if you get here, the folder isn't open so open it
pID = Shell("explorer.exe " & strDirectory, vbNormalFocus)
102:
End Sub