不同CAD版本間也可以引用的Library(clsACAD)

一般常用的CAD大多是AutoCAD，關於AutoCAD VBA的資源也滿多可以搜尋的到，因此起初開發的主力通常是AutoCADVBA。

另外還有一種常用的CAD叫做ZWCAD(中望CAD)，本來筆者的機關還沒有改制前還可以使用，但自從被政府接收之後就不能使用了，在轉換期間我意外發現，ZWCAD專業版竟然也有支援VBA的功能，雖然安裝程序跟AutoCAD不太一樣，而且重點是引用物件只要把AutoCAD改成ZWCAD即可，還有一些要判斷物件名稱的時候可能會稍微不一樣。

一直到筆者機關改制之後，我們又換了一個新的CAD，叫做PorgeCAD，更讓我意外的是，他竟然也有支援VBA，看到這裡，果然VBA還是一個很有用途的工具，但天不從人願，他的物件已經不是改幾個字就能處理了，筆者在研究了一陣子，做了一個轉換的工具，將AutoCAD、ZwCAD、PorgeCAD，之間所有可以引用的項目，把他們串起來了，只需要透過一開始的選單去決定便可以呼叫裡面各式功能。

PorgeCAD跟AutoCAD最主要的差異就在於點跟點群組的物件概念不同，其他都大同小異，因此只要把點資料處理好，基本上其他就能直接沿用。

Private mo As Object

Private pa As Object

Public acaddoc As Object

Public CADVer As String

Private Sub Class_Initialize()

If Sheets("總表").optAutoCAD = True Then

    strCAD = "AutoCAD.application"

    CADVer = "AUTOCAD"

    

ElseIf Sheets("總表").optZWCAD = True Then

    

    strCAD = "ZWCAD.Application"

    CADVer = "ZWCAD"

    

ElseIf Sheets("總表").optICAD = True Then

    strCAD = "ICAD.application"

    CADVer = "ICAD"

End If

Call CADInit(strCAD)

End Sub

Private Sub CADInit(ByVal strCAD As String)

On Error Resume Next

Set acadapp = GetObject(, strCAD) '查看安裝

If Err <> 0 Then Set acadapp = CreateObject(strCAD)

acadapp.Visible = True

On Error GoTo 0

Set mo = acadapp.ActiveDocument.ModelSpace

Set pa = acadapp.ActiveDocument.PaperSpace

Set acaddoc = acadapp.ActiveDocument

End Sub

'=============transform ICAD about point and points======================

Function tranPoint(ByVal CADpt)

If CADVer <> "ICAD" Then tranPoint = CADpt: Exit Function

Set tranPoint = Library.CreatePoint(CADpt(0), CADpt(1), CADpt(2))

End Function

Function tranIPoint(ByVal ICADpt)

If CADVer <> "ICAD" Then tranIPoint = ICADpt: Exit Function

Dim tmp(2) As Double

tmp(0) = ICADpt.X

tmp(1) = ICADpt.y

tmp(2) = ICADpt.Z

tranIPoint = tmp

End Function

Function tranPoints(ByVal vertices, Optional cnt As Byte = 3)

If CADVer <> "ICAD" Then tranPoints = vertices: Exit Function

Dim myPline, myPoints, PT

    

Set myPoints = Library.CreatePoints

If cnt = 2 Then

    For i = 0 To UBound(vertices) Step cnt

    

        Set PT = Library.CreatePoint(vertices(i), vertices(i + 1))

    

        myPoints.Add

        myPoints(myPoints.Count - 1).X = PT.X

        myPoints(myPoints.Count - 1).y = PT.y

    

    Next

Else

    For i = 0 To UBound(vertices) Step cnt

    

        Set PT = Library.CreatePoint(vertices(i), vertices(i + 1), vertices(i + 2))

    

        myPoints.Add

        myPoints(myPoints.Count - 1).X = PT.X

        myPoints(myPoints.Count - 1).y = PT.y

        myPoints(myPoints.Count - 1).Z = PT.Z

    

    Next

End If

Set tranPoints = myPoints

End Function

Function tranIPoints(ByVal myPoints)

If CADVer <> "ICAD" Then tranIPoints = myPoints: Exit Function

Dim vertices()

ReDim vertices(myPoints.Count * 3 - 1)

For Each it In myPoints

vertices(0 + j) = it.X

vertices(0 + j + 1) = it.y

vertices(0 + j + 2) = it.Z

j = j + 3

Next

tranIPoints = vertices

End Function

'=============Basic function to CAD object======================

Function AddPoint(PT) As Object

If CADVer = "ICAD" Then

    Set AddPoint = mo.AddPointEntity(tranPoint(PT))

Else

    Set AddPoint = mo.AddPoint(tranPoint(PT))

End If

End Function

Function AddCircle(cpt, r) As Object

Set AddCircle = mo.AddCircle(tranPoint(cpt), r)

End Function

Function AddLine(spt, ept) As Object

Set AddLine = mo.AddLine(tranPoint(spt), tranPoint(ept))

End Function

Function AddLineCO(X1, Y1, X2, Y2) As Object

Dim spt(2) As Double

Dim ept(2) As Double

spt(0) = X1: spt(1) = Y1

ept(0) = X2: ept(1) = Y2

Set AddLineCO = AddLine(spt, ept)

End Function

Function AddPolyLine(vertices) As Object

Set AddPolyLine = mo.AddPolyLine(tranPoints(vertices))

End Function

Function Add3dPoly(vertices) '20210604 new

Set Add3dPoly = mo.Add3dPoly(tranPoints(vertices))

End Function

Function AddLWPolyLine(vertices) As Object

Set AddLWPolyLine = mo.AddLightWeightPolyline(tranPoints(vertices, 2))

End Function

Function AddArc(ByVal Center, Radius As Double, StartAngle As Double, EndAngle As Double)

Set AddArc = mo.AddArc(tranPoint(Center), Radius, StartAngle, EndAngle)

End Function

Function AddText(ByVal myText As String, ByVal txtpt, ByVal txtheight As Double, Optional alignmode As Byte = 1)

    Dim mtextObj As Object 'IntelliCAD.Text

    Dim insPt

    

    insPt = txtpt

    Set txtobj = mo.AddText(myText, tranPoint(insPt), txtheight)

    If CADVer = "ICAD" Then

    

        Select Case alignmode

        

        Case 1

            txtobj.HorizontalAlignment = 0  ' acAlignmentMiddleLeft

        Case 2

            txtobj.HorizontalAlignment = 4  ' acAlignmentMiddleCenter

        Case 3

            txtobj.HorizontalAlignment = 2 ' acAlignmentMiddleRight

        

        End Select

    

    Else

    

        Select Case alignmode

    

        Case 1

            txtobj.Alignment = 9 ' acAlignmentMiddleLeft

        Case 2

            txtobj.Alignment = 10 ' acAlignmentMiddleCenter

        Case 3

            txtobj.Alignment = 11 ' acAlignmentMiddleRight

            

        End Select

    

    End If

    

    txtobj.TextAlignmentPoint = tranPoint(insPt)

    Set AddText = txtobj

End Function