AutoCAD VBA基本多段線操作，包括建立直線，圓，圓弧等，程式碼如下。
Public Function AddLWPline(ByRef pt() As Double, ByVal width As Double) As AcadLWPolyline
Dim objPline As AcadLWPolyline
If (UBound(pt) + 1) Mod 2 <> 0 Then
MsgBox "陣列元素個數必須為偶數"
Exit Function
End If
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
objPline.ConstantWidth = width
objPline.Update
Set AddLWPline = objPline
End Function
Public Function AddLWPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, ByVal width As Double) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr(0 To 3) As Double
ptArr(0) = ptSt(0)
ptArr(1) = ptSt(1)
ptArr(2) = ptSt(0)
ptArr(3) = ptSt(1)
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddLWPlineSeg = objPline
End Function
Public Function AddPline(ByRef ptArr() As Double, ByVal width As Double) As AcadPolyline
Dim objPline As AcadPolyline
If (UBound(ptArr) + 1) Mod 3 <> 0 Then
MsgBox "陣列元素必須為3的倍數"
Exit Function
End If
Set objPline = ThisDrawing.ModelSpace.AddPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddPline = objPline
End Function
Public Function AddPlineSeg(ByVal ptSt As Variant, ByVal ptEn As Variant, ByVal width As Double) As AcadPolyline
Dim objPline As AcadPolyline
Dim ptArr(0 To 5) As Double
ptArr(0) = ptSt(0)
ptArr(1) = ptSt(1)
ptArr(2) = ptSt(2)
ptArr(3) = ptEn(0)
ptArr(4) = ptEn(1)
ptArr(5) = ptEn(2)
Set objPline = ThisDrawing.ModelSpace.AddPolyline(ptArr)
objPline.ConstantWidth = width
objPline.Update
Set AddPlineSeg = objPline
End Function
Public Function AddRectangle(ByVal pt1 As Variant, ByVal pt2 As Double, Optional width As Double = 0) As AcadLWPolyline
Dim ptArr(7) As Double
Dim objPline As AcadLWPolyline
If pt1(0) = pt2(0) Or pt1(1) = pt2(1) Then
MsgBox "建立矩形失敗！"
Exit Function
End If
ptArr(0) = MinDouble(pt1(0), pt2(0)): ptArr(1) = MaxDouble(pt1(1), pt2(1))
ptArr(2) = MinDouble(pt1(0), pt2(0)): ptArr(3) = MinDouble(pt1(1), pt2(1))
ptArr(4) = MaxDouble(pt1(0), pt2(0)): ptArr(5) = MinDouble(pt1(1), pt2(1))
ptArr(6) = MaxDouble(pt1(0), pt2(0)): ptArr(7) = MaxDouble(pt1(1), pt2(1))
Set objPline = ThisDrawing.ModelSpace.AddLightWeightPolyline(ptArr)
objPline.Closed = True
Set AddRectangle = objPline
End Function
Public Function AddPolygon(ByVal ptCen As Variant, ByVal number As Integer, ByVal radius As Double, Optional width As Double = 0, Optional angle As Double = 0) As AcadLWPolyline
Dim objPline As AcadLWPolyline
Dim ptArr() As Double
ReDim ptArr(2 * number - 1)
Dim ang As Double
ang = 2 * PI / number
Dim i As Integer
For i = 0 To 2 * number - 1
If i Mod 2 = 0 Then
ptArr(i) = ptCen(0) + radius * Cos((i \ 2) * ang)
ElseIf i Mod 2 <> 0 Then
ptArr(i) = ptCen(1) + radius * Sin((i \ 2) * ang)
End If
Next i
Set objPline = AddLWPline(ptArr, width)
objPline.Closed = True
objPline.Rotate ptCen, angle
objPline.Update
End Function
Public Sub TestPolyline()
Dim ptArr1(0 To 7) As Double
Dim objLWPline As AcadLWPolyline
ptArr1(0) = 0: ptArr1(1) = 0: ptArr1(2) = 60: ptArr1(3) = 0
ptArr1(4) = 60: ptArr1(5) = 40: ptArr1(6) = 0: ptArr1(7) = 60
Set objLWPline = AddLWPline(ptArr1, 0.2)
Dim ptArr2(0 To 8) As Double
ptArr2(0) = 100: ptArr2(1) = 0: ptArr2(2) = 0: ptArr2(3) = 160
ptArr2(4) = 0: ptArr2(5) = 0: ptArr2(6) = 160: ptArr2(7) = 40: ptArr2(8) = 0
AddPline ptArr2, 0.3
Dim pt1(0 To 2) As Double
Dim pt2(0 To 2) As Double
pt1(0) = 100: pt1(1) = 100: pt1(2) = 0
pt2(0) = 150: pt2(1) = 100: pt2(2) = 0
AddLWPlineSeg pt1, pt2, 0.1
Dim pt3(0 To 2) As Double
pt3(0) = 200: pt3(1) = 100: pt3(2) = 0
AddPlineSeg pt2, pt3, 0.5
'Dim pt4(0 To 2) As Double
'pt4(0) = 170: pt4(1) = 140: pt4(2) = 0
'AddRectangle pt1, pt4, 0
Dim pt5(0 To 2) As Double
pt5(0) = 30: pt5(1) = 130: pt5(2) = 0
AddPolygon pt5, 6, 30, 0, 0
objLWPline.SetBulge 0, 0.5
objLWPline.Update
End Sub
程式碼完。
註釋掉的程式碼提示型別不匹配。