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
