Недавно делал что-то подобное:
Option Explicit
' Для замкнутых облегченных полилиний
Sub WriteCoorsToTextFile()
Dim oSset As AcadSelectionSet
Dim oPoly As AcadLWPolyline
Dim oEntity As AcadEntity
Dim coorArr As Variant
Dim ftype(1) As Integer
Dim fdata(1) As Variant
On Error GoTo Something_Wrong_Here
For Each oSset In ThisDrawing.SelectionSets
If oSset.Name = "$Parcels$" Then
oSset.Delete
End If
Next
Set oSset = ThisDrawing.SelectionSets.Add("$Parcels$")
ftype(0) = 0: ftype(1) = 70
fdata(0) = "LWPOLYLINE": fdata(1) = 1
oSset.SelectOnScreen ftype, fdata
Dim tmpArr() As Variant
Dim I, j, m As Long
Dim fName, inpStr As String
Dim fDesc As Integer
fDesc = FreeFile
fName = InputBox("Enter file name without extension", "File Name")
fName = ThisDrawing.Path & "\" & fName & ".txt"
Open fName For Output As fDesc
j = 1
m = 1
For Each oEntity In oSset
Set oPoly = oEntity
coorArr = Get_LWPlineVertices(oPoly)
inpStr = "* Area of polyline" & j & " * " & Format(oPoly.Area, "0.0000")
Print #fDesc, inpStr
For I = 0 To UBound(coorArr, 1)
inpStr = Str(m) & Chr(32) & Str(coorArr(I, 0)) & "," & Str(coorArr(I, 1))
Print #fDesc, inpStr
m = m + 1
Next I
j = j + 1
Next oEntity
Close #fDesc
ThisDrawing.SelectionSets.Item("$Parcels$").Delete
Something_Wrong_Here:
MsgBox Err.Description
End Sub
Public Function Get_LWPlineVertices(oPoly As AcadLWPolyline) As Variant
Dim oCoords As Variant
Dim vCnt, vxcnt, iCnt, jCnt As Integer
oCoords = oPoly.Coordinates
vCnt = 0
vxcnt = (UBound(oCoords) - 1) / 2
ReDim ptArray(0 To vxcnt, 0 To 1)
For iCnt = 0 To vxcnt
For jCnt = 0 To 1
ptArray(iCnt, jCnt) = oCoords(vCnt)
vCnt = vCnt + 1
Next jCnt
Next iCnt
Get_LWPlineVertices = ptArray
End Function
____________________________
Переделай по обстоятельствам
Fatty
~'J'~