как перебрать координаты всех полилиний и раздельно сохранить их в файле

Option Explicit
' Extract road lines data information to text files
' Parcels must be lwpolylines only
Private Sub WritePlinesToTextFiles(ByVal strFold As String, strPat As String)
Dim oSset As AcadSelectionSet
Dim oPoly As AcadLWPolyline
Dim oEntity As AcadEntity
Dim coorArr As Variant
Dim ftype(0) As Integer
Dim fdata(0) 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
fdata(0) = "LWPOLYLINE"
oSset.SelectOnScreen ftype, fdata
Dim tmpArr() As Variant
Dim i, j, m As Long
Dim fName, inpStr As String
Dim fDesc As Integer
m = 1
For Each oEntity In oSset
Set oPoly = oEntity
coorArr = Get_LWPlineVertices(oPoly)
fName = strFold & "\" & strPat & CStr(m) & ".txt"
fDesc = FreeFile
Open fName For Output As fDesc
j = 1
For i = 0 To UBound(coorArr, 1)
inpStr = Str(coorArr(i, 0)) & "," & Str(coorArr(i, 1))
Print #fDesc, inpStr
Next i
j = j + 1
Close #fDesc
m = m + 1
Next oEntity
ThisDrawing.SelectionSets.Item("$Parcels$").Delete
Something_Wrong_Here:
If Err Then
MsgBox Err.Description
 End If
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
Function DirExists(ByVal strDirName As String) As Boolean
    ' Chris Rae's VBA Code Archive - http://chrisrae.com/vba
    ' Code from the Deployment Wizard, passed on by Will Rickards.
    On Error Resume Next
    DirExists = (GetAttr(strDirName) And vbDirectory) = vbDirectory
    Err.Clear
End Function
Sub Doit()
Dim fp As String
Dim fx As String
fp = "C:\AutoLoft" '//<-- change the full path of folder here
fx = "Polyline #" '//<-- change the file name prefix
If DirExists(fp) Then
WritePlinesToTextFiles fp, fx
End If
End Sub

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