建立多义线的缓冲区Buffer
Public Sub test2()' Begin the selection
Dim returnObj As AcadObject
Dim basePnt As Variant
ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"
Dim myarr As Variant
myarr = bufferPointsArray(returnObj, 3, True) '返回一个多义线Buffer点变体数组
MsgBox UBound(myarr)
End Sub Private Function bufferPointsArray(ByVal ent As AcadEntity, ByVal offsetDistance As Double, ByVal added As Boolean) As Variant
' On Error GoTo Errhandler
If offsetDistance = 0 Then
MsgBox "偏移距离必须不为0!"
Exit Function
End If
Dim pts, pts1, pts2 As Variant
Dim offsetObj As Variant
Dim i As Integer
If ent.ObjectName = "AcDb2dPolyline" Then
Dim plObj As AcadPolyline
Set plObj = ent
Dim pl1 As AcadPolyline
Dim pl2 As AcadPolyline
offsetObj = plObj.Offset(offsetDistance)
Set pl1 = offsetObj(0)
pts1 = pl1.Coordinates
pl1.Delete
offsetObj = plObj.Offset(-1 * offsetDistance)
Set pl2 = offsetObj(0)
pts2 = pl2.Coordinates
pl2.Delete
'---
pts = pts1
For i = LBound(pts2) To UBound(pts2) Step 3
ReDim Preserve pts(UBound(pts) + 3)
pts(UBound(pts) - 2) = pts2(UBound(pts2) - (i + 2))
pts(UBound(pts) - 1) = pts2(UBound(pts2) - (i + 1))
pts(UBound(pts) - 0) = pts2(UBound(pts2) - i)
Next
ElseIf ent.ObjectName = "AcDbPolyline" Then
Dim lwpObj As AcadLWPolyline
Set lwpObj = ent
Dim lwp1 As AcadLWPolyline
Dim lwp2 As AcadLWPolyline
offsetObj = lwpObj.Offset(offsetDistance)
Set lwp1 = offsetObj(0)
pts1 = lwp1.Coordinates
lwp1.Delete
offsetObj = lwpObj.Offset(-1 * offsetDistance)
Set lwp2 = offsetObj(0)
pts2 = lwp2.Coordinates
lwp2.Delete
'---
ReDim pts(0)
For i = LBound(pts1) To UBound(pts1) Step 2
If i = 0 Then
ReDim Preserve pts(UBound(pts) + 2)
Else
ReDim Preserve pts(UBound(pts) + 3)
End If
pts(UBound(pts) - 2) = pts1(i)
pts(UBound(pts) - 1) = pts1(i + 1)
pts(UBound(pts)) = 0
Next
For i = LBound(pts2) To UBound(pts2) Step 2
ReDim Preserve pts(UBound(pts) + 3)
pts(UBound(pts) - 2) = pts2(UBound(pts2) - (i + 1))
pts(UBound(pts) - 1) = pts2(UBound(pts2) - i)
pts(UBound(pts)) = 0
Next
End If
ReDim ptsDbl(UBound(pts)) As Double
For i = 0 To UBound(pts)
ptsDbl(i) = pts(i)
Next
If added = True Then
Dim newPline As AcadPolyline
Set newPline = ThisDrawing.ModelSpace.AddPolyline(ptsDbl)
newPline.Closed = True
End If
bufferPointsArray = ptsDbl
Exit Function
Errhandler:
MsgBox "Function - bufferPointsArray occures error: " + Err.Description
End Function
Function retVar() As Variant
Dim a(0 To 1) As Double
a(0) = 1: a(1) = 2
retVar = a
End Function
当Offset不能创建实体时没有考虑. 楼主没有多义线的圆弧部分，欠缺！！！
页:
[1]