yifengpan |
2009-12-18 21:40 |
Public Sub GetText_控制点() '提取AutoCAD中测量点坐标 Const PLayer As String = "GCD" '定义测量点所在图层,"*"代表所有 Const FileName As String = "d:\ds_pointsets_GCD.dat" '定义保存测量点路径 Dim adText As AcadText Dim adSS As AcadSelectionSet Dim fType(0 To 1) As Integer, fData(0 To 1) 'On Error Resume Next Set adSS = ThisDrawing.SelectionSets.Add("adSS") If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS") adSS.Clear fType(0) = 0: fData(0) = "TEXT": fType(1) = 8: fData(1) = PLayer '过滤条件 adSS.Select acSelectionSetAll, , , fType, fData Open FileName For Append As #1 For Each adText In adSS Print #1, Format(adText.InsertionPoint(0) - 1, "0.00"), Format(adText.InsertionPoint(1) + 2, "0.00"), adText.TextString Next adText Close #1 adSS.Delete '选择集删除 MsgBox "提取成功!" End Sub Public Sub GetLWPOLYLINE_等高线() '提取AutoCAD中多段线段点坐标 Const PLayer As String = "DGX" '定义测量点所在图层,"*"代表所有 Const FileName As String = "d:\ds_pointsets_DGX.dat" '定义保存测量点路径 Dim Lwpl As AcadLWPolyline Dim adSS As AcadSelectionSet Dim i As Integer Dim Pt As Variant Dim fType(0 To 1) As Integer, fData(0 To 1) Set adSS = ThisDrawing.SelectionSets.Add("adSS") If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS") adSS.Clear fType(0) = 0: fData(0) = "LWPOLYLINE": fType(1) = 8: fData(1) = PLayer '过滤条件 adSS.Select acSelectionSetAll, , , fType, fData Open FileName For Append As #1 For Each Lwpl In adSS Pt = Lwpl.Coordinates Dim xdataOut As Variant Dim xtypeOut As Variant For i = 0 To UBound(Pt) Step 2 Print #1, Format(Pt(i), "0.00"), Format(Pt(i + 1), "0.00"), Lwpl.Elevation Next i Next Lwpl Close #1 adSS.Delete '选择集删除 MsgBox "提取成功!" End Sub Public Sub GetPOLYLINE_等高线() '提取AutoCAD中多段线段点坐标 Const PLayer As String = "DGX" '定义测量点所在图层,"*"代表所有 Const FileName As String = "d:\ds_pointsets_DGX.dat" '定义保存测量点路径 Dim Lwpl As AcadPolyline Dim adSS As AcadSelectionSet Dim i As Integer Dim Pt As Variant Dim fType(0 To 1) As Integer, fData(0 To 1) Set adSS = ThisDrawing.SelectionSets.Add("adSS") If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS") adSS.Clear fType(0) = 0: fData(0) = "POLYLINE": fType(1) = 8: fData(1) = PLayer '过滤条件 adSS.Select acSelectionSetAll, , , fType, fData Open FileName For Append As #1 For Each Lwpl In adSS Pt = Lwpl.Coordinates Dim xdataOut As Variant Dim xtypeOut As Variant For i = 0 To UBound(Pt) Step 3 Print #1, Format(Pt(i), "0.00"), Format(Pt(i + 1), "0.00"), Format(Pt(i + 2), "0.00") Next i Next Lwpl Close #1 adSS.Delete '选择集删除 MsgBox "提取成功!" End Sub Public Sub GetBLANK_白化() '提取AutoCAD中多段线段白化范围 Const PLayer As String = "圈定" '定义测量点所在图层,"*"代表所有 Const FileName As String = "d:\d.bln" '定义保存测量点路径 Dim Lwpl As AcadLWPolyline Dim adSS As AcadSelectionSet Dim i As Integer Dim Pt As Variant Dim fType(0 To 1) As Integer, fData(0 To 1) Set adSS = ThisDrawing.SelectionSets.Add("adSS") If Err Then Set adSS = ThisDrawing.SelectionSets.Add("adSS") adSS.Clear fType(0) = 0: fData(0) = "LWPOLYLINE": fType(1) = 8: fData(1) = PLayer '过滤条件 adSS.Select acSelectionSetAll, , , fType, fData Open FileName For Append As #1 For Each Lwpl In adSS Pt = Lwpl.Coordinates Dim xdataOut As Variant Dim xtypeOut As Variant Print #1, (UBound(Pt) + 1) / 2 & ",0" For i = 0 To UBound(Pt) Step 2 Print #1, Format(Pt(i), "0.00") & "," & Format(Pt(i + 1), "0.00") Next i Next Lwpl Close #1 adSS.Delete '选择集删除 MsgBox "提取成功!" End Sub |
|