求一段测量两点距离的代码

jsxygshh

markc0826 发表于 2012-9-12 11:00

先谢谢了
调试成功

jsxygshh

markc0826 发表于 2012-9-12 11:00

再请教一个问题，此代码是否可以用数组的方式量取，然后写入EXCEL呢

jsxygshh

下面是我在你的帮助下写的，请帮助修改一下：用数组的方式或其他方式量取多个距离，然后分别输入到EXCEL不同的单元格中，深表感谢！

2. Public acadApp As Object
   
3. Public acadDoc As Object
   
4. Public ssetObj As AcadSelectionSet
   
5. Public ssobj As AcadSelectionSet
   
6. Public Xlapp As Object
   
7. Public WT As Object
   
8. Private Sub Command4_Click() '测量长度
   
9.     Dim acadDoc As AcadDocument
   
10.     Set acadApp = GetObject(, "AutoCAD.Application")
    
11.     If Err Then
    
12.         Err.Clear
    
13.         Set acadApp = CreateObject("AutoCAD.Application")
    
14.         If Err Then End
    
15.     End If
    
16.     acadApp.Visible = True
    
17.     Set acadDoc = acadApp.ActiveDocument
    
18.     Set Xlapp = GetObject(, "Excel.Application")
    
19.     Set WT = Xlapp.ActiveWorkbook.ActiveSheet
    
20.     AppActivate "AUTOCAD"
    
21.    
    
22.     Dim PT1 As Variant
    
23.     Dim Dis As Double
    
24.     Dim YoN
    
25.     YoN = vbYes
    
26.     Do Until YoN = vbNo
    
27.     PT1 = acadDoc.Utility.GetPoint(, "1st Point")
    
28.     Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
    
29.     Xlapp.ActiveCell = Dis
    
30.     YoN = MsgBox("The Distance is :" & Dis & "，是否继续？", vbYesNo)
    
31. Loop   
    
32. End Sub

Public acadApp As Object<br /> Public acadDoc As Object<br /> Public ssetObj As AcadSelectionSet<br /> Public ssobj As AcadSelectionSet<br /> Public Xlapp As Object<br /> Public WT As Object<br /> Private Sub Command4_Click() '测量长度 <br />     Dim acadDoc As AcadDocument<br />     Set acadApp = GetObject(, "AutoCAD.Application")<br />     If Err Then<br />         Err.Clear<br />         Set acadApp = CreateObject("AutoCAD.Application")<br />         If Err Then End<br />     End If<br />     acadApp.Visible = True<br />     Set acadDoc = acadApp.ActiveDocument<br />     Set Xlapp = GetObject(, "Excel.Application")<br />     Set WT = Xlapp.ActiveWorkbook.ActiveSheet<br />     AppActivate "AUTOCAD"<br />     <br />     Dim PT1 As Variant<br />     Dim Dis As Double<br />     Dim YoN<br />     YoN = vbYes<br />     Do Until YoN = vbNo<br />     PT1 = acadDoc.Utility.GetPoint(, "1st Point")<br />     Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")<br />     Xlapp.ActiveCell = Dis<br />     YoN = MsgBox("The Distance is :" & Dis & "，是否继续？", vbYesNo)<br /> Loop    <br /> End Sub

markc0826

看来您程式是写在excel中然後呼叫AutoCAD去抓资讯，这样子您的loop回圈应该写在Excel的运行上才有办法连续抓取数据，目前程式这样写法只做到确定ACAD抓到的单一数据是你要的，若不是或点错，可以重新点选这种功能，而无法连续传递多笔数据回Excel。
另外一个思维您考虑看看，将程式写在ACAD然後资料丢到Excel中也是可行的，端看你的主要作业软体是什麽？...您参考参考..

jsxygshh

markc0826 发表于 2012-9-12 12:10
看来您程式是写在excel中然後呼叫AutoCAD去抓资讯，这样子您的loop回圈应该写在Excel的运行上才有办法连续抓 ...

没有用数组的方式可以量取多个距离，但是需要每次都按“确定”，是否可以在选择结束以后再按键盘上的回车键结束呢？（结束本过程）

2. Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
   
3. Public acadApp As Object
   
4. Public acadDoc As Object
   
5. Public ssetObj As AcadSelectionSet
   
6. Public ssobj As AcadSelectionSet
   
7. Public Xlapp As Object
   
8. Public WT As Object
   
9. Private Sub Command4_Click() '测量长度
   
10.     Dim acadDoc As AcadDocument
    
11.     Set acadApp = GetObject(, "AutoCAD.Application")
    
12.     If Err Then
    
13.         Err.Clear
    
14.         Set acadApp = CreateObject("AutoCAD.Application")
    
15.         If Err Then End
    
16.     End If
    
17.     acadApp.Visible = True
    
18.     Set acadDoc = acadApp.ActiveDocument
    
19.     Set Xlapp = GetObject(, "Excel.Application")
    
20.     Set WT = Xlapp.ActiveWorkbook.ActiveSheet
    
21.     AppActivate "AUTOCAD"
    
22.     Dim PT1 As Variant
    
23.     Dim Dis As Double
    
24.     Dim YoN
    
25.     YoN = vbYes
    
26.     Do Until YoN = vbNo
    
27.         PT1 = acadDoc.Utility.GetPoint(, "1st Point")
    
28.         Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
    
29.         Xlapp.ActiveCell = Dis
    
30.         Xlapp.ActiveCell.Offset(1, 0).Select
    
31.         YoN = MsgBox("已经测量，是否继续？", vbYesNo)
    
32.     Loop
    
33. End Sub
    

Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long<br /> Public acadApp As Object<br /> Public acadDoc As Object<br /> Public ssetObj As AcadSelectionSet<br /> Public ssobj As AcadSelectionSet<br /> Public Xlapp As Object<br /> Public WT As Object<br /> Private Sub Command4_Click() '测量长度 <br />     Dim acadDoc As AcadDocument<br />     Set acadApp = GetObject(, "AutoCAD.Application")<br />     If Err Then<br />         Err.Clear<br />         Set acadApp = CreateObject("AutoCAD.Application")<br />         If Err Then End<br />     End If<br />     acadApp.Visible = True<br />     Set acadDoc = acadApp.ActiveDocument<br />     Set Xlapp = GetObject(, "Excel.Application")<br />     Set WT = Xlapp.ActiveWorkbook.ActiveSheet<br />     AppActivate "AUTOCAD"<br />     Dim PT1 As Variant<br />     Dim Dis As Double<br />     Dim YoN<br />     YoN = vbYes<br />     Do Until YoN = vbNo<br />         PT1 = acadDoc.Utility.GetPoint(, "1st Point")<br />         Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")<br />         Xlapp.ActiveCell = Dis<br />         Xlapp.ActiveCell.Offset(1, 0).Select<br />         YoN = MsgBox("已经测量，是否继续？", vbYesNo)<br />     Loop<br /> End Sub<br />

请帮助修改一下，达到以上效果，先谢谢

jsxygshh

望大家给予帮助，深表感谢

jsxygshh

在线等大家的帮助！

Flyingdancing

1.     Do Until YoN = vbNo
   
2.         PT1 = acadDoc.Utility.GetPoint(, "1st Point")
   
3.         Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
   
4.         Xlapp.ActiveCell = Dis
   
5.         Xlapp.ActiveCell.Offset(1, 0).Select
   
6.         YoN = MsgBox("已经测量，是否继续？", vbYesNo)
   
7.     Loop

复制代码

改为：

1. on error resume next
   
2.         label:
   
3.         PT1 = acadDoc.Utility.GetPoint(, "1st Point")
   
4.         Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
   
5.         Xlapp.ActiveCell = Dis
   
6.         Xlapp.ActiveCell.Offset(1, 0).Select
   
7.         if err then
   
8.         exit sub
   
9.         else
   
10.         goto label
    
11. end if

复制代码

jsxygshh

Flyingdancing 发表于 2012-9-13 16:04
改为：

谢谢你的帮助,在你的帮助下已经调试成功,可以正常使用了,深表感谢

yuanji007

两点的坐标读出来再用两点间的距离求法