Cad vba——导出桩号和标注距离并标面积

Public Function creatsel() As AcadSelectionSet
On Error Resume Next
Dim mys As String
mys = "mys"
Dim sel As AcadSelectionSet
   If Not IsNull(ThisDrawing.SelectionSets.Item(mys)) Then
       Set creatsel = ThisDrawing.SelectionSets.Item(mys)
       creatsel.Delete
    End If
Set creatsel = ThisDrawing.SelectionSets.Add(mys)
End Function
Sub 横断面桩号()
'On Error GoTo erro
Dim textlayer As AcadLayer
Dim dimlayer As AcadLayer
Dim sel As AcadSelectionSet
Dim txtfile As String
Dim mypt As Variant
txtfile = "C:\Users\Administrator\Desktop\坐标点.txt"
Open txtfile For Append As #1
Do
    Set sel = creatsel()
    sel.SelectOnScreen
    If sel.Count = 0 Then GoTo erro
    For i = 0 To sel.Count - 1
    If InStr(1, sel.Item(i).ObjectName, "text", vbTextCompare) > 0 Then
         If sel.Item(i).Layer = "横断面桩号" Then
             Print #1, sel.Item(i).TextString
         End If
    End If
    If InStr(1, sel.Item(i).ObjectName, "dime", vbTextCompare) > 0 Then
         If sel.Item(i).Layer = "0" Then
             Print #1, Format(sel.Item(i).Measurement, "0.00")
         End If
    End If
    
    If InStr(1, sel.Item(i).ObjectName, "lyline", vbTextCompare) > 0 Then
If sel.Item(i).Closed = True Then
    mypt = sel.Item(i).Coordinate(0)
    Dim mypt3(2) As Double
    mypt3(0) = mypt(0):    mypt3(1) = mypt(1):    mypt3(2) = 0
 Set txt = ThisDrawing.ModelSpace.AddText(Format(sel.Item(i).Area, "0.00"), mypt3, 3)
         If sel.Item(i).Layer = "滩地挖方" Then
             Print #1, Format(sel.Item(i).Area, "0.00")
         End If
         End If
    End If
    Next i
Loop

erro:
Close

MsgBox "OK    CAD二次开发qq:443440204", , "版权qq443440204"
End Sub