Работает только с активным слоем. Конверитует палитру в RGB
поумолчанию сохраняет в 1 файл со всеми слоями "C:\temp\polygon.csv" и N-файлов равное количеству слоев путь тот же, только название файлов от 001 до 999
Спойлер
Код: Выделить всё
Sub Shape2csv()
Dim a1 As Long, a2 As Long, a3 As Long, a4 As Long, a5 As Long, a6 As Long, R As Long, G As Long, B As Long
Dim x As Double, Xend As Double, y As Double, Yend As Double
Dim Stn As String, St As String, S As String, Stall As String, txt As String, alltxt As String, massiv() As String
Dim n As Node, n2 As Node
Dim s1 As Shape, s2 As Object, sr As New ShapeRange
Dim i As Integer
Dim MyFile
If ActiveSelectionRange.Count = 0 Then Set sr = activeLayer.FindShapes _
Else Set sr = ActiveSelectionRange.Shapes.FindShapes
If sr.Count = 0 Then Exit Sub
' Application.EventsEnabled = False '
' Application.Optimization = True '
' ActiveDocument.PreserveSelection = True '
a1 = sr.Count
ReDim massiv(1 To a1)
a2 = 1
a5 = 1
MyFile = FreeFile
Set s1 = activeLayer.Shapes(a2)
For Each s1 In sr
i = i + 1
a4 = s1.Curve.SubPaths.Count
If s1.Fill.UniformColor.Type <> cdrColorRGB Then
s1.Fill.UniformColor.ConvertToRGB
End If
Stall = ""
If a4 = 1 Then
a5 = s1.Curve.Segments.Count
St = ""
Stn = ""
For a3 = 1 To a5
If a3 = a5 Then
Set n = s1.Curve.Segments.Item(a3).StartNode
x = n.PositionX
y = n.PositionY
Xend = s1.Curve.Segments.Item(1).StartNode.PositionX
Yend = s1.Curve.Segments.Item(1).StartNode.PositionY
Stn = Stn & x & " " & y & "," & Xend & " " & Yend
Else
Set n = s1.Curve.Segments.Item(a3).StartNode
x = n.PositionX
y = n.PositionY
Stn = Stn & x & " " & y & ","
End If
Stall = "(" & Stn & ")"
Next a3
Else
For a6 = 1 To a4
a5 = s1.Curve.SubPaths.Item(a6).Segments.Count
St = ""
Stn = ""
For a3 = 1 To a5
If a3 = a5 Then
Set s2 = s1.Curve.SubPaths.Item(a6)
Set n = s2.Segments.Item(a3).StartNode
x = n.PositionX
y = n.PositionY
Set n2 = s2.Segments.Item(1).StartNode
Xend = n2.PositionX
Yend = n2.PositionY
Stn = Stn & x & " " & y & "," & Xend & " " & Yend
Else
Set s2 = s1.Curve.SubPaths.Item(a6)
Set n = s2.Segments.Item(a3).StartNode
x = n.PositionX
y = n.PositionY
Stn = Stn & x & " " & y & ","
End If
Next a3
If a6 = a4 Then
St = "(" & Stn & ")"
Stall = Stall + St
Else
St = "(" & Stn & ")"
Stall = Stall + St + ","
End If
Next a6
End If
massiv(i) = Stall
Next s1
For i = a1 To 1 Step -1
If a1 = 1 Then
R = s2.Fill.UniformColor.RGBRed
G = s2.Fill.UniformColor.RGBGreen
B = s2.Fill.UniformColor.RGBBlue
Else
R = activeLayer.Shapes(i).Fill.UniformColor.RGBRed
G = activeLayer.Shapes(i).Fill.UniformColor.RGBGreen
B = activeLayer.Shapes(i).Fill.UniformColor.RGBBlue
End If
txt = Chr(34) + "POLYGON(" & massiv(i) & ")" + Chr(34) + "," & R & ":" & G & ":" & B & vbCrLf
Open ("C:\temp\polygon_" & Format(i, "###000") & ".csv") For Output As #MyFile 'Эти 3 строки убрать если не нужно экспортировать каждую кривую в отдельный файл
Print #MyFile, "WKT,RGB" & vbCrLf & txt 'Путь прописан "C:\temp\polygon.csv"
Close '
alltxt = alltxt + txt
Next i
Open ("C:\temp\polygon.csv") For Output As #MyFile 'Эти 3 строки убрать если не нужен 1 файл со всеми слоями
Print #MyFile, "WKT,RGB" & vbCrLf & alltxt 'Путь прописан "C:\temp\polygon.csv"
Close '
' Application.EventsEnabled = True
' Application.Optimization = False
' ActiveDocument.PreserveSelection = False
MsgBox "Все сделал" '
End SubУчтите что экспортируются только координаты точек. лучше слой экспортировать в формат wmf и обратно импортировать в корел.
