关于CAD使用VB导出多线段坐标的问题

lmz_whut

这是VBA文件
多线段坐标获取.zip (7.96 KB, 下载次数: 3)

2014-11-28 09:43 上传

下载次数: 3
下载积分: PB币 -1
请勿使用多线程下载工具下载论坛附件！

代码如下

1. Sub main()
   
2. '连接EXCEL
   
3.        Dim xlApp As Excel.Application
   
4.        Dim xlbook As Excel.Workbook
   
5.        Dim xlSheet As Excel.Worksheet
   
6.        On Error Resume Next
   
7.        Set xlApp = GetObject(, "excel.application")
   
8.        If Err <> 0 Then
   
9.          Err.Clear
   
10.          Set xlApp = CreateObject("excel.application")
    
11.          Set xlbook = xlApp.Workbooks.Add
    
12.          If Err <> 0 Then
    
13.            MsgBox "无法启动excel"
    
14.            Exit Sub
    
15.          End If
    
16.        End If
    
17.        Set xlbook = xlApp.ActiveWorkbook
    
18.        Set xlSheet = xlbook.ActiveSheet
    
19.        xlApp.Visible = True
    
20. 
    
21. Dim pickObj As AcadEntity         '保存被选择图元的对象变量
    
22. Dim pickPnt As Variant            '选择图元时的拾取点变量
    
23. Dim gpnt As Variant
    
24. Dim pntcnt As Integer
    
25.     Dim point As Variant
    
26.     Dim x0 As Double, y0 As Double
    
27.     Dim point_temp_x As Double, point_temp_y As Double
    
28.     Dim x(50) As Double, y(50) As Double    '保存钢束导线的各点坐标的变量
    
29.     Dim x1 As Double, y1 As Double
    
30.     Dim i As Integer, j As Long, k As Integer, n As Integer, l As Integer
    
31.     n = 1   'n为钢束的根数
    
32.     l = 1
    
33. 
    
34. 
    
35. Do
    
36. ThisDrawing.Utility.GetEntity pickObj, pickPnt, "请选择导线："
    
37. '以下语句获取导线的顶点
    
38. gpnt = pickObj.Coordinates
    
39. pntcnt = UBound(gpnt)
    
40.     On Error Resume Next  '引入错误处理
    
41.        point = ThisDrawing.Utility.GetPoint _
    
42.                 (, vbCrLf & "请选择钢束的坐标原点") '坐标原点
    
43.        x0 = point(0)
    
44.        y0 = point(1)
    
45.     If Err <> 0 Then  '引入错误处理
    
46.       'Close #1
    
47.       Exit Sub
    
48.     End If
    
49.             
    
50.     For i = 0 To (pntcnt - 1) Step 2  '导线的各点循环
    
51.        x(i) = gpnt(i) - x0
    
52.        y(i) = gpnt(i + 1) - y0
    
53.        x1 = x(i) - point_temp_x
    
54.        y1 = y(i) - point_temp_y
    
55.        j = j + 1
    
56.        k = k + 1
    
57.        If i = 0 And gpnt(i) <> 0 And gpnt(i + 1) <> 0 Then '过滤多余数据
    
58.          xlSheet.Cells(j, l) = "序号" & "(束" & n & ")"
    
59.          xlSheet.Cells(j, l + 1) = "X坐标"
    
60.          xlSheet.Cells(j, l + 2) = "Y坐标"
    
61.          xlSheet.Cells(j + 1, l) = k
    
62.          xlSheet.Cells(j + 1, l + 1) = Format(x(i), "0.000")
    
63.          xlSheet.Cells(j + 1, l + 2) = Format(y(i), "0.000")
    
64.        ElseIf i > 0 And gpnt(i) <> 0 And gpnt(i + 1) <> 0 Then
    
65.          xlSheet.Cells(j + 1, l) = k
    
66.          xlSheet.Cells(j + 1, l + 1) = Format(x(i), "0.000")
    
67.          xlSheet.Cells(j + 1, l + 2) = Format(y(i), "0.000")
    
68.        End If
    
69.        point_temp_x = x(i)
    
70.        point_temp_y = y(i)
    
71.     Next i
    
72.     n = n + 1
    
73. Loop Until pntcnt = 0
    
74.    
    
75. End Sub

复制代码

使用方法如下：
1.在CAD中工具>宏>加载工程，选择该文件，然后ALT+F8运行该宏。
2.首先选择钢束导线（即你要写入excel表的pline线），然后选择坐标的原点；
重复上述步骤可选择多条导线，最后两个回车即可按各自的坐标原点将选中导线的坐标输出到excel表中
3.程序可自动检测是否启动excel，若已打开excel表则直接写入此表中，否则自动启动excel，建立新表写入数据。

问题来了，获取第二条多线段坐标的时候，会把第一条最后一行的坐标覆盖掉。
如下图

求修正代码

lmz_whut

不知道把问题描述清楚没，自占沙发

阿伯才的风格

问题来了的下半句难道不是……

ybb2008

文科的，没用过CAD啊。拿PBB了。

远古小兵

我不用cad，但是我很感谢楼主的pb

lmz_whut

阿伯才的风格 发表于 2014-11-28 10:05
问题来了的下半句难道不是……

lmz_whut

远古小兵 发表于 2014-11-28 10:06
我不用cad，但是我很感谢楼主的pb

学过vb么

kfc0013

围观AA

远古小兵

lmz_whut 发表于 2014-11-28 10:16
学过vb么

学过c#

cjy__05

远古小兵 发表于 2014-11-28 10:56
学过c#

啊 不知道楼主在说什么

guoyanzhe

不懂，拿钱、帮顶帖子。

guoyanzhe

我的PBB好少的，羡慕楼上几位。

raymai97

简单粗暴的做法：

1. Sub main()
   
2. '连接EXCEL
   
3.        Dim xlApp As Excel.Application
   
4.        Dim xlbook As Excel.Workbook
   
5.        Dim xlSheet As Excel.Worksheet
   
6.        On Error Resume Next
   
7.        Set xlApp = GetObject(, "excel.application")
   
8.        If Err <> 0 Then
   
9.          Err.Clear
   
10.          Set xlApp = CreateObject("excel.application")
    
11.          Set xlbook = xlApp.Workbooks.Add
    
12.          If Err <> 0 Then
    
13.            MsgBox "无法启动excel"
    
14.            Exit Sub
    
15.          End If
    
16.        End If
    
17.        Set xlbook = xlApp.ActiveWorkbook
    
18.        Set xlSheet = xlbook.ActiveSheet
    
19.        xlApp.Visible = True
    
20. 
    
21. Dim pickObj As AcadEntity         '保存被选择图元的对象变量
    
22. Dim pickPnt As Variant            '选择图元时的拾取点变量
    
23. Dim gpnt As Variant
    
24. Dim pntcnt As Integer
    
25.     Dim point As Variant
    
26.     Dim x0 As Double, y0 As Double
    
27.     Dim point_temp_x As Double, point_temp_y As Double
    
28.     Dim x(50) As Double, y(50) As Double    '保存钢束导线的各点坐标的变量
    
29.     Dim x1 As Double, y1 As Double
    
30.     Dim i As Integer, j As Long, k As Integer, n As Integer, l As Integer
    
31.     n = 1   'n为钢束的根数
    
32.     l = 1
    
33. 
    
34. 
    
35. Do
    
36. ThisDrawing.Utility.GetEntity pickObj, pickPnt, "请选择导线："
    
37. '以下语句获取导线的顶点
    
38. gpnt = pickObj.Coordinates
    
39. pntcnt = UBound(gpnt)
    
40.     On Error Resume Next  '引入错误处理
    
41.        point = ThisDrawing.Utility.GetPoint _
    
42.                 (, vbCrLf & "请选择钢束的坐标原点") '坐标原点
    
43.        x0 = point(0)
    
44.        y0 = point(1)
    
45.     If Err <> 0 Then  '引入错误处理
    
46.       'Close #1
    
47.       Exit Sub
    
48.     End If
    
49.             
    
50.     For i = 0 To (pntcnt - 1) Step 2  '导线的各点循环
    
51.        x(i) = gpnt(i) - x0
    
52.        y(i) = gpnt(i + 1) - y0
    
53.        x1 = x(i) - point_temp_x
    
54.        y1 = y(i) - point_temp_y
    
55.        j = j + 1
    
56.        k = k + 1
    
57.        If i = 0 And gpnt(i) <> 0 And gpnt(i + 1) <> 0 Then '过滤多余数据
    
58.          j = j + 1 ' <- 简单粗暴万岁
    
59.          xlSheet.Cells(j, l) = "序号" & "(束" & n & ")"
    
60.          xlSheet.Cells(j, l + 1) = "X坐标"
    
61.          xlSheet.Cells(j, l + 2) = "Y坐标"
    
62.          xlSheet.Cells(j + 1, l) = k
    
63.          xlSheet.Cells(j + 1, l + 1) = Format(x(i), "0.000")
    
64.          xlSheet.Cells(j + 1, l + 2) = Format(y(i), "0.000")
    
65.        ElseIf i > 0 And gpnt(i) <> 0 And gpnt(i + 1) <> 0 Then
    
66.          xlSheet.Cells(j + 1, l) = k
    
67.          xlSheet.Cells(j + 1, l + 1) = Format(x(i), "0.000")
    
68.          xlSheet.Cells(j + 1, l + 2) = Format(y(i), "0.000")
    
69.        End If
    
70.        point_temp_x = x(i)
    
71.        point_temp_y = y(i)
    
72.     Next i
    
73.     n = n + 1
    
74. Loop Until pntcnt = 0
    
75.    
    
76. End Sub

复制代码

raymai97

最近天气很热，得来点凉皮解暑

xing3kong

没用过CAD 路过了

xing3kong

还是吃个凉皮吧

远古小兵

路过，悄悄拿钱。

Vitasilk

路過,圍觀一下

Vitasilk

不會用,進來學習一下

kfc0013

拿福利，这样