- 积分
- 13278
- 最后登录
- 2024-4-17
- 精华
- 0
- 阅读权限
- 205
- 主题
- 389
- UID
- 1078191
- 帖子
- 33106
- PB币
- 127511
- 威望
- 6
- 贡献
- 3
- 技术
- 7
- 活跃
- 722
- UID
- 1078191
- 帖子
- 33106
- PB币
- 127511
- 贡献
- 3
- 技术
- 7
- 活跃
- 722
|
本帖最后由 lmz_whut 于 2014-11-28 21:48 编辑
这是VBA文件
多线段坐标获取.zip
(7.96 KB, 下载次数: 3)
代码如下
- Sub main()
- '连接EXCEL
- Dim xlApp As Excel.Application
- Dim xlbook As Excel.Workbook
- Dim xlSheet As Excel.Worksheet
- On Error Resume Next
- Set xlApp = GetObject(, "excel.application")
- If Err <> 0 Then
- Err.Clear
- Set xlApp = CreateObject("excel.application")
- Set xlbook = xlApp.Workbooks.Add
- If Err <> 0 Then
- MsgBox "无法启动excel"
- Exit Sub
- End If
- End If
- Set xlbook = xlApp.ActiveWorkbook
- Set xlSheet = xlbook.ActiveSheet
- xlApp.Visible = True
- Dim pickObj As AcadEntity '保存被选择图元的对象变量
- Dim pickPnt As Variant '选择图元时的拾取点变量
- Dim gpnt As Variant
- Dim pntcnt As Integer
- Dim point As Variant
- Dim x0 As Double, y0 As Double
- Dim point_temp_x As Double, point_temp_y As Double
- Dim x(50) As Double, y(50) As Double '保存钢束导线的各点坐标的变量
- Dim x1 As Double, y1 As Double
- Dim i As Integer, j As Long, k As Integer, n As Integer, l As Integer
- n = 1 'n为钢束的根数
- l = 1
- Do
- ThisDrawing.Utility.GetEntity pickObj, pickPnt, "请选择导线:"
- '以下语句获取导线的顶点
- gpnt = pickObj.Coordinates
- pntcnt = UBound(gpnt)
- On Error Resume Next '引入错误处理
- point = ThisDrawing.Utility.GetPoint _
- (, vbCrLf & "请选择钢束的坐标原点") '坐标原点
- x0 = point(0)
- y0 = point(1)
- If Err <> 0 Then '引入错误处理
- 'Close #1
- Exit Sub
- End If
-
- For i = 0 To (pntcnt - 1) Step 2 '导线的各点循环
- x(i) = gpnt(i) - x0
- y(i) = gpnt(i + 1) - y0
- x1 = x(i) - point_temp_x
- y1 = y(i) - point_temp_y
- j = j + 1
- k = k + 1
- If i = 0 And gpnt(i) <> 0 And gpnt(i + 1) <> 0 Then '过滤多余数据
- xlSheet.Cells(j, l) = "序号" & "(束" & n & ")"
- xlSheet.Cells(j, l + 1) = "X坐标"
- xlSheet.Cells(j, l + 2) = "Y坐标"
- xlSheet.Cells(j + 1, l) = k
- xlSheet.Cells(j + 1, l + 1) = Format(x(i), "0.000")
- xlSheet.Cells(j + 1, l + 2) = Format(y(i), "0.000")
- ElseIf i > 0 And gpnt(i) <> 0 And gpnt(i + 1) <> 0 Then
- xlSheet.Cells(j + 1, l) = k
- xlSheet.Cells(j + 1, l + 1) = Format(x(i), "0.000")
- xlSheet.Cells(j + 1, l + 2) = Format(y(i), "0.000")
- End If
- point_temp_x = x(i)
- point_temp_y = y(i)
- Next i
- n = n + 1
- Loop Until pntcnt = 0
-
- End Sub
复制代码使用方法如下:
1.在CAD中工具>宏>加载工程,选择该文件,然后ALT+F8运行该宏。
2.首先选择钢束导线(即你要写入excel表的pline线),然后选择坐标的原点;
重复上述步骤可选择多条导线,最后两个回车即可按各自的坐标原点将选中导线的坐标输出到excel表中
3.程序可自动检测是否启动excel,若已打开excel表则直接写入此表中,否则自动启动excel,建立新表写入数据。
问题来了,获取第二条多线段坐标的时候,会把第一条最后一行的坐标覆盖掉。
如下图
求修正代码
|
|