新手求教，前期绑定怎么改为后期帮定，感谢！
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 于 2013-7-20 21:10 编辑
Private Function 画多线段(颜色 As String) As AcadLWPolyline 改为
Private Function 画多线段(颜色 As String) As object
还有不要引用auto CAD库
应该是选取所有点完毕后，再判断点数是否大于等于2，最后再画多段线和量取长度。 yshf 发表于 2013-7-20 21:05 static/image/common/back.gif
Private Function 画多线段(颜色 As String) As AcadLWPolyline 改为
Private Function 画多线段(颜 ...
首先谢谢这位大哥的解答，后期绑定这样改可以用了，但是关于画多线段问题，如果在选取所有点后判断点数的话，是不能实时看见一条已画点与下一个点之间的橡皮筋（活动的线）的，可偏偏这一点是要实现的，不知要怎么办 本帖最后由 yshf 于 2013-7-22 22:49 编辑
试用以下函数(注意：在VB中则将ThisDrawing修改为acadapp.ActiveDocument)：Public Function AddPline(Col)
'画多段线，并返回其长度
Dim p1 As Variant
Dim p2 As Variant
Dim n As Integer
Dim m As Integer
Dim pt() As Double
Dim Ent As AcadLWPolyline'在VB中改为 Dim Ent As Object
Dim Pdbz As Boolean
Dim Fhz
On Error Resume Next
p1 = ThisDrawing.Utility.GetPoint(, vbCrLf + "第1点：")
p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "下一点<或结束>:")
If TypeName(p2) = "Empty" Then
'MsgBox "只有输入一点，不能画多段线"
Fhz = "只有输入一点，不能画多段线"
Else
n = 2: m = 2 * n - 1
ReDim Preserve pt(m)
pt(0) = p1(0): pt(1) = p1(1)
pt(m - 1) = p2(0): pt(m) = p2(1)
Set Ent = ThisDrawing.ModelSpace.AddLightWeightPolyline(pt)
Ent.color = Col
Ent.Update
Pdbz = True
Do While Pdbz = True
p1 = p2: p2 = Empty
p2 = ThisDrawing.Utility.GetPoint(p1, vbCrLf & "下一点<或结束>:")
If TypeName(p2) = "Empty" Then
Pdbz = False
Exit Do
Else
n = n + 1: m = n * 2 - 1
ReDim Preserve pt(m)
pt(m - 1) = p2(0): pt(m) = p2(1)
Ent.Coordinates = pt
Ent.Update
End If
Loop
Fhz = Ent.Length
End If
AddPline = Fhz
End Function
yshf 发表于 2013-7-22 22:27 static/image/common/back.gif
试用以下函数(注意：在VB中则将ThisDrawing修改为acadapp.ActiveDocument)：
还没测试，但是无论如何都要感谢您，谢谢！
页:
[1]