본 코드는 BricsCAD에서 사용중인 코드입니다. AutoCAD와 다를수 있으니 참고바랍니다.
한 프로젝트혹은 하나의장비 도면을관리할때한개의 캐드 파일에서관리하는곳이많습니다.
리비전 이력이나 부품의 조립관계확인등,, 한 파일에서관리하는게 가장 이상적이지만 가장큰걸림돌은 도면출력이라생각됩니다.
여러 캐드 서드파티 프로그램들이그 문제를 해결하기위해 다양한방법으로 도면을관리하고있습니다.
저 또한 캐드에서 가장 먼저 만들고자주 쓰는 프로그램이출력 프로그램입니다.
그래서 제가
사용하는 프로그램 소스를공개하며, 이 글을 보시는 분도 자신에게 맞게 수정, 사용하셔서 출력에 보내는 시간이줄었으면 합니다.
'출력 순서 정의
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
'----------------------------------------------------------------------------------
'UCS 초기화
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
'----------------------------------------------------------------------------------
'Main
Sub Block_Print()
On Error Resume Next
Set Doc = ThisDrawing
Dim i As Integer
'출력 순서 설정
Dim PrtSq As PrtSquence
PrtSq = DD
'TD: 좌상단 출력후 우측으로 출력, 한줄 아래로 이동후 반복, 정렬기준 좌측하단
'TU: 좌상단 출력후 우측으로 출력, 한줄 아래로 이동후 반복, 정렬기준 좌측상단
'DD: 좌하단 출력후 우측으로 출력, 한줄 위로 이동후 반복, 정렬기준 좌측하단
'DU: 좌하단 출력후 우측으로 출력, 한줄 위로 이동후 반복, 정렬기준 좌측상단
'프린트 이름
Dim PrntName As String
'PDF 출력
Dim PDFPrint As Boolean
PDFPrint = True
If PDFPrint Then
'PDF 프린트 이름 설정
PrntName = "PDF.pc3"
Else
'프린트 이름 설정
PrntName = "HP LaserJet 5100 Series PCL6.pc3"
End If
'구조체 사용
Dim PBox() As PrtArea
Doc.Utility.Prompt vbCr & "출력 프로그램..."
'UCS 초기화 함수 실행
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
'PDF 출력
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
'미리보기
'Doc.Plot.DisplayPlotPreview acFullPreview
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
