Enum PrtSquence
TD
TU
DD
DU
End Enum
Type PrtArea
X1 As Double
Y1 As Double
X2 As Double
Y2 As Double
End Type
Dim Doc As AcadDocument
Sub Sort(ByRef Data() As PrtArea, Sq As PrtSquence)
Dim lb As Integer, ub As Integer
Dim i As Integer, J As Integer
lb = LBound(Data)
ub = UBound(Data)
For i = lb To ub - 1
For J = i + 1 To ub
If Sq = TD Or Sq = TU Then
If Sq = TD Then
If Data(i).Y1 < Data(J).Y1 Then Call CData(Data(i), Data(J))
Else
If Data(i).Y2 < Data(J).Y2 Then Call CData(Data(i), Data(J))
End If
Else
If Sq = DD Then
If Data(i).Y1 > Data(J).Y1 Then Call CData(Data(i), Data(J))
Else
If Data(i).Y2 > Data(J).Y2 Then Call CData(Data(i), Data(J))
End If
End If
Next
Next
For i = lb To ub - 1
For J = i + 1 To ub
If Sq = TD Or Sq = DD Then
If Data(i).X1 > Data(J).X1 And Int(Data(i).Y1) = Int(Data(J).Y1) _
Then Call CData(Data(i), Data(J))
Else
If Data(i).X1 > Data(J).X1 And Int(Data(i).Y2) = Int(Data(J).Y2) _
Then Call CData(Data(i), Data(J))
End If
Next
Next
End Sub
Sub CData(ByRef D1 As PrtArea, ByRef D2 As PrtArea)
Dim tmp As PrtArea
tmp = D2
D2 = D1
D1 = tmp
End Sub
Sub DBObjKill(ByRef SelOb As AcadSelectionSet)
Dim i As Integer, J As Integer
Dim SelB1 As AcadBlockReference, SelB2 As AcadBlockReference
Dim ReMv() As AcadEntity
ReDim ReMv(SelOb.Count - 1)
For i = 0 To SelOb.Count - 1
If SelOb(i).ObjectName = "AcDbBlockReference" Then
For J = i + 1 To SelOb.Count - 1
If SelOb(J).ObjectName = "AcDbBlockReference" Then
Set SelB1 = SelOb.Item(i)
Set SelB2 = SelOb.Item(J)
If Int(SelB1.InsertionPoint(0)) = Int(SelB2.InsertionPoint(0)) And _
Int(SelB1.InsertionPoint(1)) = Int(SelB2.InsertionPoint(1)) Then
Set ReMv(J) = SelB2
End If
End If
Next
End If
Next
SelOb.RemoveItems ReMv
For i = 0 To UBound(ReMv)
If Not ReMv(i) Is Nothing Then
ReMv(i).Delete
End If
Next
Set SelB1 = Nothing
Set SelB2 = Nothing
Erase ReMv
End Sub
Sub UCS_Clear()
Dim NewUCS As AcadUCS
Dim NewOrg(0 To 2) As Double
Dim NewXAxis(0 To 2) As Double
Dim NewYAxis(0 To 2) As Double
Dim NewUCSName As String
NewOrg(0) = 0: NewOrg(1) = 0: NewOrg(2) = 0
NewXAxis(0) = 1: NewXAxis(1) = 0: NewXAxis(2) = 0
NewYAxis(0) = 0: NewYAxis(1) = 1: NewYAxis(2) = 0
NewUCSName = "World"
Set NewUCS = Doc.UserCoordinateSystems.Add(NewOrg, _
NewXAxis, NewYAxis, NewUCSName)
Doc.ActiveUCS = NewUCS
Dim oCurViewP As AcadViewport
Dim dCenter(1) As Double
Dim dTarget(2) As Double
If (ThisDrawing.ActiveSpace = acModelSpace) Then
Set oCurViewP = ThisDrawing.ActiveViewport
If Not (oCurViewP Is Nothing) Then
dTarget(0) = 0#
dTarget(1) = 0#
dTarget(2) = 0#
oCurViewP.Target = dTarget
ThisDrawing.ActiveViewport = oCurViewP
Set oCurViewP = Nothing
End If
End If
Set NewUCS = Nothing
End Sub
Sub Block_Print()
On Error Resume Next
Set Doc = ThisDrawing
Dim i As Integer
Dim PrtSq As PrtSquence
PrtSq = DD
Dim PrntName As String
Dim PDFPrint As Boolean
PDFPrint = True
If PDFPrint Then
PrntName = "PDF.pc3"
Else
PrntName = "HP LaserJet 5100 Series PCL6.pc3"
End If
Dim PBox() As PrtArea
Doc.Utility.Prompt vbCr & "출력 프로그램..."
Call UCS_Clear
Doc.SelectionSets("BlockPrint").Delete
Dim SelObj As AcadSelectionSet
Set SelObj = Doc.SelectionSets.Add("BlockPrint")
Dim BName(2) As String
BName(0) = "A$C7E9A3D3E"
BName(1) = "A$C220D1AB8"
BName(2) = "Form A4"
Dim BNC As Integer
BNC = UBound(BName) + 2
ReDim FilterType(BNC) As Integer
ReDim FilterData(BNC) As Variant
FilterType(0) = -4
FilterData(0) = "<OR"
For i = 1 To BNC - 1
FilterType(i) = 2
FilterData(i) = BName(i - 1)
Next
FilterType(BNC) = -4
FilterData(BNC) = "OR>"
SelObj.SelectOnScreen FilterType, FilterData
If SelObj.Count = 0 Then Exit Sub
Call DBObjKill(SelObj)
Dim P1 As Variant, P2 As Variant
ReDim PBox(SelObj.Count - 1)
For i = 0 To SelObj.Count - 1
SelObj.Item(i).GetBoundingBox P1, P2
ReDim Preserve P1(0 To 1)
ReDim Preserve P2(0 To 1)
PBox(i).X1 = P1(0)
PBox(i).Y1 = P1(1)
PBox(i).X2 = P2(0)
PBox(i).Y2 = P2(1)
Next
Call Sort(PBox, PrtSq)
Dim Layout As AcadLayout
Set Layout = Doc.ActiveLayout
With Layout
.ConfigName = PrntName
.StandardScale = acScaleToFit
.StyleSheet = "acad.ctb"
.PlotWithPlotStyles = True
.PlotType = acWindow
.PlotRotation = ac90degrees
.PlotViewportBorders = False
.PlotViewportsFirst = True
.CanonicalMediaName = "A4"
.PaperUnits = acMillimeters
.ShowPlotStyles = False
.CenterPlot = True
If PDFPrint Then
.PlotRotation = ac0degrees
Else
.PlotRotation = ac90degrees
End If
End With
Dim PrtAct As Boolean
For i = 0 To UBound(PBox)
Doc.Utility.Prompt vbCr & i + 1 & " / " & UBound(PBox) + 1
P1(0) = PBox(i).X1
P1(1) = PBox(i).Y1
P2(0) = PBox(i).X2
P2(1) = PBox(i).Y2
Layout.SetWindowToPlot P1, P2
Layout.RefreshPlotDeviceInfo
If PDFPrint Then
PrtAct = Doc.Plot.PlotToFile("D:\" & str(i + 1) & ".pdf")
Else
Doc.Plot.PlotToDevice
End If
Next
Doc.Utility.Prompt vbCrLf & "출력완료" & vbCrLf
SelObj.Delete
Doc.SelectionSets("BlockPrint").Delete
Erase PBox
End Sub
