田草博客

互联网田草博客


网友交流QQ群:11740834 需注明申请加入原因

微信 公众号:ByCAD

邮箱:tiancao1001x126.com
ByCAD,微信公众号
首页 | 普通 | 电脑 | AutoCAD | VB/VB.NET | FLash | 结构 | 建筑 | 电影 | BIM | 规范 | 软件 | ID
-随机-|-分布-
-博客论坛-|-﨣﨤﨧﨨-
-网站导航-|-规范下载-
-BelovedFLash欣赏-

用户登陆
用户:
密码:
 

站点日历
73 2024 - 3 48
     12
3456789
10111213141516
17181920212223
24252627282930
31


站点统计

最新评论



短片 《太阳花》 隐藏日志,无权浏览
未知 PLine 线增加点   [ 日期:2007-06-04 ]   [ 来自:本站原创 ]  HTML
PLine 线增加点



'***********************************************************************

'给多义线增加顶点*********************************************************'
Sub AddPointToPline()
    Dim PL As AcadLWPolyline
    Dim PickPnt As Variant
    'On Error Resume Next
    ThisDrawing.Utility.GetEntity PL, PickPnt, "请选择一根多段线"
    
    Dim P As Variant                                        '多义线顶点数组
    P = PL.Coordinates
    Dim PS As AcadPoint
    Dim PE As AcadPoint
    Set PS = ThisDrawing.ModelSpace.AddPoint(Point3D(P(0), P(1), 0)) '用蓝色点标明多段线的起点
    PS.color = acBlue
    Dim L As Integer
    L = UBound(P)
    Set PE = ThisDrawing.ModelSpace.AddPoint(Point3D(P(L - 1), P(L), 0)) '用红色点标明多段线的终点
    PE.color = acRed
    
    Dim TempPoint1 As Variant                               '点取多义线上的一点,此点将在添加点(TempPoint2)之前
    Dim TempPoint2 As Variant                               '点取一点,此点就是要添加的点,在多义线中排在TempPoint1点之后
ChongXinXuanZe:
    ThisDrawing.Utility.InitializeUserInput 1, ""
    TempPoint1 = ThisDrawing.Utility.GetPoint(, "选择多义线的一个顶点(预添加点的前一个点): ")
    Dim k As Integer
    Dim I As Integer
    '如果点不在是多段线的顶点,则重新选择点
    For I = 0 To UBound(P) - 1
        If P(I) = TempPoint1(0) And P(I + 1) = TempPoint1(1) Then k = I + 2: Exit For
    Next
    If k = 0 Then
       ThisDrawing.Utility.Prompt "你选择的点不是多义线的顶点请重新选择。" & Chr(13)
       GoTo ChongXinXuanZe
    End If
    
    ThisDrawing.Utility.InitializeUserInput 1, ""
    TempPoint2 = ThisDrawing.Utility.GetPoint(TempPoint1, "选择要添加的点: ")
    '重新定义数值
    Dim P1() As Double
    ReDim P1(UBound(P) + 2)
    '将点坐标插入到数组中
    For I = 0 To k - 1
        P1(I) = P(I)
    Next
    P1(k) = TempPoint2(0): P1(k + 1) = TempPoint2(1)
    For I = k + 2 To UBound(P) + 2
        P1(I) = P(I - 2)
    Next
    '重新绘制多段线
    Dim XPL As AcadLWPolyline
    Set XPL = ThisDrawing.ModelSpace.AddLightWeightPolyline(P1)
    '特性匹配多段线
    XPL.Layer = PL.Layer
    XPL.color = PL.color
    Dim SW As Double
    Dim EW As Double
    For I = 0 To Int(L / 2) - 1
        PL.GetWidth I, SW, EW
        XPL.SetWidth I, SW, EW
    Next
    XPL.SetWidth I, SW, EW
    XPL.SetWidth I + 1, SW, EW
    If PL.Closed = True Then XPL.Closed = True
    '删除原来的多段线和起点及终点
    PL.Delete
    PS.Delete
    PE.Delete
    
End Sub




Sub L2PL()
    Dim objSelected As Object
    Dim L  As AcadLine
    Dim Pl As AcadLWPolyline
    Dim XuanZeJi As AcadSelectionSet
    Dim i As Long
    Dim P() As Double
    On Error GoTo E
    Set XuanZeJi = ThisDrawing.SelectionSets.Add("xline")
    '定义过滤机制
    Dim FilterType(0) As Integer
    Dim FilterData(0) As Variant
    FilterType(0) = 0
    FilterData(0) = "line"
    
    ThisDrawing.Utility.Prompt "请按顺序选择线段:" & Chr(13)
    
    XuanZeJi.SelectOnScreen FilterType, FilterData
    ReDim Preserve P(XuanZeJi.Count * 4 - 1)
    
    '对选择集中的线段进行操作
    For Each objSelected In XuanZeJi
        If TypeOf objSelected Is AcadLine Then
            Set L = objSelected
            P(i) = L.StartPoint(0)
            P(i + 1) = L.StartPoint(1)
            P(i + 2) = L.EndPoint(0)
            P(i + 3) = L.EndPoint(1)
            i = i + 4
        Else
            '删除选择集
            ThisDrawing.SelectionSets.item("xline").Delete
        End If
    Next
    Set Pl = ThisDrawing.ModelSpace.AddLightWeightPolyline(P)
    For i = 0 To XuanZeJi.Count * 2 - 1
        Pl.SetWidth i, 1, 1
    Next i
    ThisDrawing.SelectionSets.item("xline").Delete
    ThisDrawing.Application.Update
    Exit Sub
E:
        ThisDrawing.SelectionSets.item("xline").Delete

End Sub


[本日志由 田草 于 2007-12-12 05:35 PM 编辑]


引用这个评论 田草 于 2007-09-19 05:31 PM 发表评论: 
其实这个功能cad的Pline编辑已经可以做到只是有点繁琐。
PlineEdit 命令pe简化命令

发表评论 - 不要忘了输入验证码哦!
作者: 用户:  密码:   注册? 验证:  防止恶意留言请输入问题答案:2*4=?  
评论:

禁止表情
禁止UBB
禁止图片
识别链接
识别关键字

字体样式 文字大小 文字颜色
插入粗体文本 插入斜体文本 插入下划线
左对齐 居中对齐 右对齐
插入超级链接 插入邮件地址 插入图像
插入 Flash 插入代码 插入引用
插入列表 插入音频文件 插入视频文件
插入缩进符合
点击下载按钮 下标 上标
水平线 简介分割标记
表  情
 
Tiancao Blog All Rights Reserved 田草博客 版权所有
Copyright ©