VBA在CAD画无法预知顶点数的多线段 - 石陆软件屋

在CAD VBA中，可以使用AddLightWeightPolyline(VerticesList) 函数画2D多线段。其中

参数VerticesList必须是预先定义的一个数组，数组的元素个数为2的倍数，其含义为：

[x0,y0,x1,y1,...,xn-1,yn-1](n为顶点个数)。

    下面是一个画550个顶点的封闭多线段的程序实例：
Sub Example_AddLightWeightPolyline()
    ' This example creates a lightweight polyline in model space.

    Dim plineObj As AcadLWPolyline
    Dim points(0 To 1099) As Double

    ' Define the 2D polyline points
    For i = 0 To 1099 Step 2
        points(i) = i * 5: points(i + 1) = i * 10
    Next

    ' Create a lightweight Polyline object in model space
    Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)
    plineObj.Closed = True
    ZoomAll

    有时候我们会遇到这样一个问题：就是顶点的个数在画线之前是无法预知的！

    在网上可以查到，有人用动态数组的方法解决了这个问题。但该方法需要反复地

画n-1条多线段（分别是2，3，...，n个顶点），而且还要反复地删除n-2条多线段（画

下一条之前删除上一条）。该法固然可行，但未免有点笨，执行效率不高。

    作者采用一个比较巧妙的办法较好地解决了这个问题，其思路如下：
选画一条只有2个顶点的多线段，即多线段的第一段，然后在一个循环结构中利用多

线段的AddVertex 属性逐次在最后一个顶点上添加顶点：
AddVertex Index, Point

下面是一个程序实例:

Sub Example_AddVertex()
    'VBA在CAD中画多线段并标注顶点点名
    Dim plineObj As AcadLWPolyline
    Dim points(0 To 3) As Double
    Dim basePnt As Variant
    Dim returnPnt As Variant
    Dim returnString
    Dim s As String
    Dim textObj As AcadText

    '先画出第1段
    returnString = ThisDrawing.Utility.GetString(False, "请输入点名:J1 ")
    If returnString = "" Then returnString = "J1"
    basePnt = ThisDrawing.Utility.GetPoint(, "指定起点: ")
    Set textObj = ThisDrawing.ModelSpace.AddText(returnString, basePnt, 3#)  '标注起点点名
    s = Left(returnString, 1)
    returnString = ThisDrawing.Utility.GetString(False, "请输入点名: " + s + "2") '提示下一个点名的默认值
    If returnString = "" Then returnString = s + "2"
    returnPnt = ThisDrawing.Utility.GetPoint(basePnt, "指定下一点: ")
    Set textObj = ThisDrawing.ModelSpace.AddText(returnString, returnPnt, 3#)  '标注第2点点名
    points(0) = basePnt(0): points(1) = basePnt(1)       '多线段起点
    points(2) = returnPnt(0): points(3) = returnPnt(1)   '多线段第2点
    Set plineObj = ThisDrawing.ModelSpace.AddLightWeightPolyline(points)  '画多线段第1段

    ' 依次在最后一个顶点上添加顶点
    Dim newVertex(0 To 1) As Double ' 定义新顶点坐标数组
    i = 2
    k = 2
    Do
      s = Left(returnString, 1)
      returnString = ThisDrawing.Utility.GetString(True, "请输入点名或结束闭合(空格): " + s + Trim(Str(k + 1))) '提示下一个点名的默认值
      If InStr(returnString, " ") Then
         plineObj.Closed = True
         Exit Do
      End If
      If returnString = "" Then
         returnString = s + Trim(Str(k + 1))
         k = k + 1
      Else: k = 1
      End If
      returnPnt = ThisDrawing.Utility.GetPoint(returnPnt, "指定下一点: ")
      Set textObj = ThisDrawing.ModelSpace.AddText(returnString, returnPnt, 3#)  '标注第i点点名

      newVertex(0) = returnPnt(0): newVertex(1) = returnPnt(1)
      plineObj.AddVertex i, newVertex   '在第i个顶点上添加顶点
      i = i + 1
     Loop
End Sub

[阅读字体大小: 大中小]

[本日志由 admin 于 2014-04-14 08:32 AM 编辑]

引用通告地址 (0)：
复制引用地址

http://www.cnng.net/blog/trackback.asp?tbID=76
复制引用地址

http://www.cnng.net/blog/trackback.asp?tbID=76&CP=GBK