新手求教，前期绑定怎么改为后期帮定，感谢！

火焰

Dim acadapp As Object        '只知道改这一句

'_______________________________________________________

Private Sub 加载()
    On Error Resume Next
    Set acadapp = GetObject(, "AutoCAD.application")
    If Err Then
        Err.Clear
        MsgBox "请先运行AutoCAD后再继续", 0, "错误"
        End
    End If
    acadapp.Visible = True
End Sub

'_______________________________________________________

Private Function 画多线段(颜色 As String) As AcadLWPolyline         '编译出错：用户定义类型未定义
    On Error Resume Next
    Dim 第1段数组(3) As Double
    Dim 第1点, 下一点

    '画第1段线
    第1点 = acadapp.ActiveDocument.Utility.GetPoint(, vbCrLf + "输入点：")
    下一点 = acadapp.ActiveDocument.Utility.GetPoint(第1点, vbCrLf + "输入下一点/或结束:")
    Text3.Text = TypeName(下一点)

    第1段数组(0) = 第1点(0): 第1段数组(1) = 第1点(1)
    第1段数组(2) = 下一点(0): 第1段数组(3) = 下一点(1)
    Set 画多线段 = acadapp.ActiveDocument.ModelSpace.AddLightWeightPolyline(第1段数组)
    Call 改变颜色(画多线段, 颜色)

    '依次添加顶点
    Dim 新点数组(1) As Double
    Dim i As Integer
    i = 2
    Do
        If Err Then Exit Do
        下一点 = acadapp.ActiveDocument.Utility.GetPoint(下一点, vbCrLf + "输入下一点/或结

束:")
        新点数组(0) = 下一点(0): 新点数组(1) = 下一点(1)
        画多线段.AddVertex i, 新点数组
        i = i + 1
    Loop

End Function

'_______________________________________________________

Private Sub Command1_Click()        '量取长度
    Call 加载

    '激活 AutoCAD 窗口
    AppActivate acadapp.Caption

    Text1.Text = 画多线段(acRed).Length

End Sub

最后还有一个问题：为什么我执行量取长度后，如果画第1点后取消，它便自己画出第1点与原点(0,0,0)的连线，并计算其长度，怎么改函数使其画第1点后取消，便是画线，这个问题困扰我很久了，总是没解决，感谢不尽啊！

yshf

Private Function 画多线段(颜色 As String) As AcadLWPolyline 改为
      Private Function 画多线段(颜色 As String) As object
还有不要引用auto CAD库

应该是选取所有点完毕后，再判断点数是否大于等于2，最后再画多段线和量取长度。

火焰

yshf 发表于 2013-7-20 21:05
Private Function 画多线段(颜色 As String) As AcadLWPolyline 改为
      Private Function 画多线段(颜 ...

首先谢谢这位大哥的解答，后期绑定这样改可以用了，但是关于画多线段问题，如果在选取所有点后判断点数的话，是不能实时看见一条已画点与下一个点之间的橡皮筋（活动的线）的，可偏偏这一点是要实现的，不知要怎么办

yshf

试用以下函数(注意：在VB中则将ThisDrawing修改为acadapp.ActiveDocument)：

2. Public Function AddPline(Col)
   
3.     '画多段线，并返回其长度
   
4.     Dim p1 As Variant
   
5.     Dim p2 As Variant
   
6.     Dim n As Integer
   
7.     Dim m As Integer
   
8.     Dim pt() As Double
   
9.     Dim Ent As AcadLWPolyline  '在VB中改为 Dim Ent As Object
   
10.     Dim Pdbz As Boolean
    
11.     Dim Fhz
    
12.    
    
13.     On Error Resume Next
    
14.    
    
15.     p1 = ThisDrawing.Utility.GetPoint(, vbCrLf + "第1点：")
    
16.     p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "下一点<或结束>:")
    
17.    
    
18.     If TypeName(p2) = "Empty" Then
    
19.        'MsgBox "只有输入一点，不能画多段线"
    
20.        Fhz = "只有输入一点，不能画多段线"
    
21.     Else
    
22.        n = 2: m = 2 * n - 1
    
23.        ReDim Preserve pt(m)
    
24.       
    
25.        pt(0) = p1(0): pt(1) = p1(1)
    
26.        pt(m - 1) = p2(0): pt(m) = p2(1)
    
27.       
    
28.        Set Ent = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
    
29.        Ent.color = Col
    
30.        Ent.Update
    
31.       
    
32.        Pdbz = True
    
33.       
    
34.        Do While Pdbz = True
    
35.           p1 = p2: p2 = Empty
    
36.           p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "下一点<或结束>:")
    
37.          
    
38.           If TypeName(p2) = "Empty" Then
    
39.              Pdbz = False
    
40.              Exit Do
    
41.           Else
    
42.          
    
43.              n = n + 1: m = n * 2 - 1
    
44.              ReDim Preserve pt(m)
    
45.             
    
46.              pt(m - 1) = p2(0): pt(m) = p2(1)
    
47.              Ent.Coordinates = pt
    
48.              Ent.Update
    
49.           End If
    
50.        Loop
    
51.        Fhz = Ent.Length
    
52.       
    
53.     End If
    
54.    
    
55.     AddPline = Fhz
    
56. End Function
    

Public Function AddPline(Col)<br />     '画多段线，并返回其长度<br />     Dim p1 As Variant<br />     Dim p2 As Variant<br />     Dim n As Integer<br />     Dim m As Integer<br />     Dim pt() As Double<br />     Dim Ent As AcadLWPolyline  '在VB中改为 Dim Ent As Object<br />     Dim Pdbz As Boolean<br />     Dim Fhz<br />     <br />     On Error Resume Next<br />     <br />     p1 = ThisDrawing.Utility.GetPoint(, vbCrLf + "第1点：")<br />     p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "下一点<或结束>:")<br />     <br />     If TypeName(p2) = "Empty" Then<br />        'MsgBox "只有输入一点，不能画多段线"<br />        Fhz = "只有输入一点，不能画多段线"<br />     Else<br />        n = 2: m = 2 * n - 1<br />        ReDim Preserve pt(m)<br />        <br />        pt(0) = p1(0): pt(1) = p1(1)<br />        pt(m - 1) = p2(0): pt(m) = p2(1)<br />        <br />        Set Ent = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)<br />        Ent.color = Col<br />        Ent.Update<br />        <br />        Pdbz = True<br />        <br />        Do While Pdbz = True<br />           p1 = p2: p2 = Empty<br />           p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "下一点<或结束>:")<br />           <br />           If TypeName(p2) = "Empty" Then<br />              Pdbz = False<br />              Exit Do<br />           Else<br />           <br />              n = n + 1: m = n * 2 - 1<br />              ReDim Preserve pt(m)<br />              <br />              pt(m - 1) = p2(0): pt(m) = p2(1)<br />              Ent.Coordinates = pt<br />              Ent.Update<br />           End If<br />        Loop<br />        Fhz = Ent.Length<br />        <br />     End If<br />     <br />     AddPline = Fhz<br /> End Function<br />

火焰

yshf 发表于 2013-7-22 22:27
试用以下函数(注意：在VB中则将ThisDrawing修改为acadapp.ActiveDocument)：

还没测试，但是无论如何都要感谢您，谢谢！