王咣生 发表于 2004-12-22 21:08:00

建立多义线的缓冲区Buffer

本帖最后由 作者 于 2004-12-23 12:21:38 编辑 <br /><br /> Public Sub test2()<BR>                       ' Begin the selection<BR>                       Dim returnObj As AcadObject<BR>                       Dim basePnt As Variant<BR>                       <BR>                       ThisDrawing.Utility.GetEntity returnObj, basePnt, "Select an object"<BR>                       Dim myarr As Variant<BR>                       <BR>                       myarr = bufferPointsArray(returnObj, 3, True)       '返回一个多义线Buffer点变体数组<BR>                                <BR>                       MsgBox UBound(myarr)<BR>End Sub



Private Function bufferPointsArray(ByVal ent As AcadEntity, ByVal offsetDistance As Double, ByVal added As Boolean) As Variant<BR>'                       On Error GoTo Errhandler<BR>                       <BR>                       If offsetDistance = 0 Then<BR>                                                       MsgBox "偏移距离必须不为0!"<BR>                                                       Exit Function<BR>                       End If<BR>                       <BR>                       Dim pts, pts1, pts2 As Variant<BR>                       Dim offsetObj As Variant<BR>                       Dim i As Integer<BR>                       <BR>                       If ent.ObjectName = "AcDb2dPolyline" Then<BR>                                                       Dim plObj As AcadPolyline<BR>                                                       Set plObj = ent<BR>                                                       Dim pl1 As AcadPolyline<BR>                                                       Dim pl2 As AcadPolyline<BR>                                                       offsetObj = plObj.Offset(offsetDistance)<BR>                                                       Set pl1 = offsetObj(0)<BR>                                                       pts1 = pl1.Coordinates<BR>                                                       pl1.Delete<BR>                                                       offsetObj = plObj.Offset(-1 * offsetDistance)<BR>                                                       Set pl2 = offsetObj(0)<BR>                                                       pts2 = pl2.Coordinates<BR>                                                       pl2.Delete<BR>                                                       '---<BR>                                                       pts = pts1<BR>                                                       For i = LBound(pts2) To UBound(pts2) Step 3<BR>                                                                                       ReDim Preserve pts(UBound(pts) + 3)<BR>                                                                                       pts(UBound(pts) - 2) = pts2(UBound(pts2) - (i + 2))<BR>                                                                                       pts(UBound(pts) - 1) = pts2(UBound(pts2) - (i + 1))<BR>                                                                                       pts(UBound(pts) - 0) = pts2(UBound(pts2) - i)<BR>                                                       Next<BR>                       ElseIf ent.ObjectName = "AcDbPolyline" Then<BR>                                                       Dim lwpObj As AcadLWPolyline<BR>                                                       Set lwpObj = ent<BR>                                                       Dim lwp1 As AcadLWPolyline<BR>                                                       Dim lwp2 As AcadLWPolyline<BR>                                                       offsetObj = lwpObj.Offset(offsetDistance)<BR>                                                       Set lwp1 = offsetObj(0)<BR>                                                       pts1 = lwp1.Coordinates<BR>                                                       lwp1.Delete<BR>                                                       offsetObj = lwpObj.Offset(-1 * offsetDistance)<BR>                                                       Set lwp2 = offsetObj(0)<BR>                                                       pts2 = lwp2.Coordinates<BR>                                                       lwp2.Delete<BR>                                                       '---<BR>                                                       ReDim pts(0)<BR>                                                       For i = LBound(pts1) To UBound(pts1) Step 2<BR>                                                                                       If i = 0 Then<BR>                                                                                                                       ReDim Preserve pts(UBound(pts) + 2)<BR>                                                                                       Else<BR>                                                                                                                       ReDim Preserve pts(UBound(pts) + 3)<BR>                                                                                       End If<BR>                                                                                       pts(UBound(pts) - 2) = pts1(i)<BR>                                                                                       pts(UBound(pts) - 1) = pts1(i + 1)<BR>                                                                                       pts(UBound(pts)) = 0<BR>                                                       Next<BR>                                                       For i = LBound(pts2) To UBound(pts2) Step 2<BR>                                                                                       ReDim Preserve pts(UBound(pts) + 3)<BR>                                                                                       pts(UBound(pts) - 2) = pts2(UBound(pts2) - (i + 1))<BR>                                                                                       pts(UBound(pts) - 1) = pts2(UBound(pts2) - i)<BR>                                                                                       pts(UBound(pts)) = 0<BR>                                                       Next<BR>                       End If


                       ReDim ptsDbl(UBound(pts)) As Double<BR>                       For i = 0 To UBound(pts)<BR>                                                       ptsDbl(i) = pts(i)<BR>                       Next<BR>                       If added = True Then<BR>                                                       Dim newPline As AcadPolyline<BR>                                                       Set newPline = ThisDrawing.ModelSpace.AddPolyline(ptsDbl)<BR>                                                       newPline.Closed = True<BR>                       End If<BR>                       <BR>                       bufferPointsArray = ptsDbl<BR>                       <BR>                       Exit Function<BR>Errhandler:<BR>                       MsgBox "Function - bufferPointsArray occures error: " + Err.Description<BR>End Function


Function retVar() As Variant<BR>                       Dim a(0 To 1) As Double<BR>                       a(0) = 1: a(1) = 2<BR>                       retVar = a<BR>End Function


<FONT color=#0033ff><b>当Offset不能创建实体时没有考虑.</b></FONT>

nxy_918 发表于 2004-12-24 08:58:00

楼主没有多义线的圆弧部分，欠缺！！！
页: [1]
查看完整版本: 建立多义线的缓冲区Buffer