乐筑天下

搜索
欢迎各位开发者和用户入驻本平台 尊重版权,从我做起,拒绝盗版,拒绝倒卖 签到、发布资源、邀请好友注册,可以获得银币 请注意保管好自己的密码,避免账户资金被盗
查看: 26|回复: 1

建立多义线的缓冲区Buffer

[复制链接]

124

主题

837

帖子

9

银币

顶梁支柱

Rank: 50Rank: 50

铜币
1333
发表于 2004-12-22 21:08:00 | 显示全部楼层 |阅读模式
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不能创建实体时没有考虑.
回复

使用道具 举报

31

主题

129

帖子

5

银币

后起之秀

Rank: 20Rank: 20Rank: 20Rank: 20

铜币
253
发表于 2004-12-24 08:58:00 | 显示全部楼层
楼主没有多义线的圆弧部分,欠缺!!!
回复

使用道具 举报

发表回复

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

  • 微信公众平台

  • 扫描访问手机版

  • 点击图片下载手机App

QQ|关于我们|小黑屋|乐筑天下 繁体中文

GMT+8, 2025-3-16 16:15 , Processed in 2.908539 second(s), 57 queries .

© 2020-2025 乐筑天下

联系客服 关注微信 帮助中心 下载APP 返回顶部 返回列表