markc0826 发表于 2012-9-12 11:00 static/image/common/back.gif
先谢谢了
调试成功
markc0826 发表于 2012-9-12 11:00 static/image/common/back.gif
再请教一个问题，此代码是否可以用数组的方式量取，然后写入EXCEL呢
下面是我在你的帮助下写的，请帮助修改一下：用数组的方式或其他方式量取多个距离，然后分别输入到EXCEL不同的单元格中，深表感谢！Public acadApp As Object
Public acadDoc As Object
Public ssetObj As AcadSelectionSet
Public ssobj As AcadSelectionSet
Public Xlapp As Object
Public WT As Object
Private Sub Command4_Click() '测量长度
Dim acadDoc As AcadDocument
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then End
End If
acadApp.Visible = True
Set acadDoc = acadApp.ActiveDocument
Set Xlapp = GetObject(, "Excel.Application")
Set WT = Xlapp.ActiveWorkbook.ActiveSheet
AppActivate "AUTOCAD"
Dim PT1 As Variant
Dim Dis As Double
Dim YoN
YoN = vbYes
Do Until YoN = vbNo
PT1 = acadDoc.Utility.GetPoint(, "1st Point")
Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
Xlapp.ActiveCell = Dis
YoN = MsgBox("The Distance is :" & Dis & "，是否继续？", vbYesNo)
Loop
End Sub
看来您程式是写在excel中然後呼叫AutoCAD去抓资讯，这样子您的loop回圈应该写在Excel的运行上才有办法连续抓取数据，目前程式这样写法只做到确定ACAD抓到的单一数据是你要的，若不是或点错，可以重新点选这种功能，而无法连续传递多笔数据回Excel。
另外一个思维您考虑看看，将程式写在ACAD然後资料丢到Excel中也是可行的，端看你的主要作业软体是什麽？...您参考参考..
markc0826 发表于 2012-9-12 12:10 static/image/common/back.gif
看来您程式是写在excel中然後呼叫AutoCAD去抓资讯，这样子您的loop回圈应该写在Excel的运行上才有办法连续抓 ...
没有用数组的方式可以量取多个距离，但是需要每次都按“确定”，是否可以在选择结束以后再按键盘上的回车键结束呢？（结束本过程）Private Declare Function GetAsyncKeyState Lib "user32" (ByVal vKey As Long) As Long
Public acadApp As Object
Public acadDoc As Object
Public ssetObj As AcadSelectionSet
Public ssobj As AcadSelectionSet
Public Xlapp As Object
Public WT As Object
Private Sub Command4_Click() '测量长度
Dim acadDoc As AcadDocument
Set acadApp = GetObject(, "AutoCAD.Application")
If Err Then
Err.Clear
Set acadApp = CreateObject("AutoCAD.Application")
If Err Then End
End If
acadApp.Visible = True
Set acadDoc = acadApp.ActiveDocument
Set Xlapp = GetObject(, "Excel.Application")
Set WT = Xlapp.ActiveWorkbook.ActiveSheet
AppActivate "AUTOCAD"
Dim PT1 As Variant
Dim Dis As Double
Dim YoN
YoN = vbYes
Do Until YoN = vbNo
PT1 = acadDoc.Utility.GetPoint(, "1st Point")
Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
Xlapp.ActiveCell = Dis
Xlapp.ActiveCell.Offset(1, 0).Select
YoN = MsgBox("已经测量，是否继续？", vbYesNo)
Loop
End Sub
请帮助修改一下，达到以上效果，先谢谢
望大家给予帮助，深表感谢
在线等大家的帮助！
Do Until YoN = vbNo
PT1 = acadDoc.Utility.GetPoint(, "1st Point")
Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
Xlapp.ActiveCell = Dis
Xlapp.ActiveCell.Offset(1, 0).Select
YoN = MsgBox("已经测量，是否继续？", vbYesNo)
Loop改为：on error resume next
label:
PT1 = acadDoc.Utility.GetPoint(, "1st Point")
Dis = Format(acadDoc.Utility.GetDistance(PT1, "2nd Point") / 1000, "##0.00")
Xlapp.ActiveCell = Dis
Xlapp.ActiveCell.Offset(1, 0).Select
if err then
exit sub
else
goto label
end if
Flyingdancing 发表于 2012-9-13 16:04 static/image/common/back.gif
改为：
谢谢你的帮助,在你的帮助下已经调试成功,可以正常使用了,深表感谢
两点的坐标读出来再用两点间的距离求法