获取autocad当前窗口的所有竖直方向的直线的X坐标

shouhua000

请问如何获取AutoCAD当前窗口的所有竖直方向的直线的X坐标，并把所获取的坐标保存到一个数组里，与此同时 判断出这些直线属于哪个图层的，谢谢各位大侠

wylong

2. Sub SelectLine()
   
3.     Dim sS As AcadSelectionSet
   
4.     Dim objLine As AcadLine
   
5.     Dim LineDelta As Variant
   
6.     Dim removeObjects() As AcadEntity
   
7. 
   
8. 
   
9.     Dim fType(0 To 0) As Integer
   
10.     Dim fData(0 To 0) As Variant
    
11.     Dim AutoSelect As Boolean
    
12. 
    
13.     'AutoSelect = True
    
14. 
    
15.     On Error Resume Next
    
16.     ThisDrawing.SelectionSets("SelectText").Delete
    
17.     Set sS = ThisDrawing.SelectionSets.Add("SelectText")
    
18.     On Error GoTo 0
    
19. 
    
20.     On Error GoTo ErrHandle
    
21. 
    
22.     '创建过滤机制
    
23.     fType(0) = 0: fData(0) = "LINE"         '直线
    
24. 
    
25.     '选择符合条件的所有图元－单行文字和多行文字
    
26.     If AutoSelect Then
    
27.         '自动选择方式
    
28.         sS.Select acSelectionSetAll, , , fType, fData
    
29.     Else
    
30.         '提示用户选择
    
31.         sS.SelectOnScreen fType, fData
    
32.     End If
    
33.     If sS.Count = 0 Then Exit Sub
    
34.     i = 0
    
35. 
    
36.     For Each objLine In sS
    
37.         LineDelta = objLine.Delta
    
38.         If LineDelta(0) <> 0 Then
    
39.             ReDim Preserve removeObjects(i)
    
40.             Set removeObjects(i) = objLine
    
41.             i = i + 1
    
42.         End If
    
43.     Next
    
44.    
    
45.     sS.RemoveItems removeObjects
    
46.       
    
47.     For Each objLine In sS
    
48.         a = objLine.StartPoint
    
49.         b = a(0)
    
50.         c = c & b & vbNewLine
    
51.     Next
    
52.    
    
53.     MsgBox c
    
54. 
    
55.     '删除数组
    
56.     Erase fType: Erase fData: Erase removeObjects: Erase LineDelta
    
57. 
    
58.     '删除选择集
    
59.     sS.Clear: sS.Delete
    
60.    
    
61.     Set sS = Nothing
    
62.     Set objLine = Nothing
    
63. 
    
64.     Exit Sub
    
65. ErrHandle:
    
66.     MsgBox Err.Description, vbCritical, "产生了以下错误:"
    
67.     Err.Clear
    
68. End Sub

Sub SelectLine()<br />     Dim sS As AcadSelectionSet<br />     Dim objLine As AcadLine<br />     Dim LineDelta As Variant<br />     Dim removeObjects() As AcadEntity<br /> <br /> <br />     Dim fType(0 To 0) As Integer<br />     Dim fData(0 To 0) As Variant<br />     Dim AutoSelect As Boolean<br /> <br />     'AutoSelect = True<br /> <br />     On Error Resume Next<br />     ThisDrawing.SelectionSets("SelectText").Delete<br />     Set sS = ThisDrawing.SelectionSets.Add("SelectText")<br />     On Error GoTo 0<br /> <br />     On Error GoTo ErrHandle<br /> <br />     '创建过滤机制<br />     fType(0) = 0: fData(0) = "LINE"         '直线<br /> <br />     '选择符合条件的所有图元－单行文字和多行文字<br />     If AutoSelect Then<br />         '自动选择方式<br />         sS.Select acSelectionSetAll, , , fType, fData<br />     Else<br />         '提示用户选择<br />         sS.SelectOnScreen fType, fData<br />     End If<br />     If sS.Count = 0 Then Exit Sub<br />     i = 0<br /> <br />     For Each objLine In sS<br />         LineDelta = objLine.Delta<br />         If LineDelta(0) <> 0 Then<br />             ReDim Preserve removeObjects(i)<br />             Set removeObjects(i) = objLine<br />             i = i + 1<br />         End If<br />     Next<br />     <br />     sS.RemoveItems removeObjects<br />       <br />     For Each objLine In sS<br />         a = objLine.StartPoint<br />         b = a(0)<br />         c = c & b & vbNewLine<br />     Next<br />     <br />     MsgBox c<br /> <br />     '删除数组<br />     Erase fType: Erase fData: Erase removeObjects: Erase LineDelta<br /> <br />     '删除选择集<br />     sS.Clear: sS.Delete<br />     <br />     Set sS = Nothing<br />     Set objLine = Nothing<br /> <br />     Exit Sub<br /> ErrHandle:<br />     MsgBox Err.Description, vbCritical, "产生了以下错误:"<br />     Err.Clear<br /> End Sub

黄玉宏

领教了，沙发高手。是我们学习的榜样。谢谢。

shouhua000

wylong 发表于 2011-11-10 15:08

谢谢wylong的答案 ，有个问题不太明白   a,b,c都没有定义呀， c = c & b & vbNewLine
这条语句的作用是什么呢？  还有就是 怎么才能判断直线所在的图层啊

黄玉宏

可以不定义，VB允许这样，实际为变体数组(包含所有)。b为每个竖直直线的起点的X坐标， c = c & b & vbNewLine作用：所有起点X坐标换行，vbNewline作用换行相当于vbCrLf，它是VB6新增的。这样显示出来的坐标是一行一个。图层名问题： objLine.Layer