CorelDRAW и CNCFoamCut
Для тех, кто только осваивает пенорезку, выкладываю макрос, переводящий чертеж из CorelDRAW в формат DAT, воспринимаемый программой CNCFoamCut.
Макрос экспортирует все выбранные (selected) кривые с активного листа в файл, при этом создает еще один лист в COREL.
Готов ответить на вопросы и рассмотреть замечания.
Attribute VB_Name = “CNCFoamCut”
Dim PointsX() As Double
Dim PointsY() As Double
Sub AllInOne()
Call Prepare
Call GetAllSelectedCurves
Call CreateAndFillNewPage
Call SavePointsToFile(GetPointsTXT, “”)
End Sub
Private Sub Prepare()
ReDim Preserve PointsX(0)
ReDim Preserve PointsY(0)
End Sub
Private Sub GetAllSelectedCurves()
ActiveDocument.Unit = cdrMillimeter
Dim PageIn As Page
Set PageIn = ActivePage
Dim sha As Shape
Dim i As Long
For i = 1 To ActiveLayer.Shapes.Count
Set sha = ActiveLayer.Shapes(i)
If sha.Selected = True Then
Call GetPointsFromShape(sha, i)
End If
Next
End Sub
Sub GetPointsFromShape(sha As Shape, i As Long)
Dim crv As Curve
Set crv = sha.Curve
Dim nod As Node
Dim x, y As Double
Dim l As Long
For Each nod In crv.Nodes
x = nod.PositionX
y = nod.PositionY
l = UBound(PointsX)
PointsX(l) = x
PointsY(l) = y
ReDim Preserve PointsX(l + 1)
ReDim Preserve PointsY(l + 1)
Next
l = UBound(PointsX)
ReDim Preserve PointsX(l - 1)
ReDim Preserve PointsY(l - 1)
End Sub
Private Sub CreateAndFillNewPage()
If UBound(PointsX) = 0 Then Exit Sub
If UBound(PointsY) = 0 Then Exit Sub
Dim PageOut As Page
Set PageOut = ActiveDocument.InsertPagesEx(1, False, ActiveDocument.Pages.Count, 210#, 297#)
PageOut.Activate
PageOut.name = "Резка " & Str(PageOut.index)
Dim i, l As Long
l = UBound(PointsX)
Dim x, x0 As Double
Dim y, y0 As Double
Dim crv As Curve
Set crv = ActiveDocument.CreateCurve
x = PointsX(0)
y = PointsY(0)
Dim sp As SubPath
Set sp = crv.CreateSubPath(x, y)
For i = 1 To l
x = PointsX(i)
y = PointsY(i)
sp.AppendLineSegment x, y
Next i
Dim s As Shape
Set s = ActiveLayer.CreateCurve(crv)
End Sub
Private Sub SavePointsToFile(PointsTXT As String, name As String)
If PointsTXT = “” Then Exit Sub
Dim filename As String
Dim dirname As String
filename = ActiveWindow.Document.filename
dirname = ActiveWindow.Document.FilePath
Dim fullfilename As String
fullfilename = ActiveWindow.Document.fullfilename
Dim p1 As Page
Set p1 = ActivePage
name = p1.name
Dim k As Integer
k = InStr(1, fullfilename, “.”)
If k > 1 Then
fullfilename = Left(fullfilename, k - 1) + " " + name + “.dat”
Open fullfilename For Output As #1
Print #1, PointsTXT
Close #1
End If
End Sub
Private Function GetPointsTXT() As String
If UBound(PointsX) = 0 Or UBound(PointsX) = 0 Then
GetPointsTXT = “”
Exit Function
End If
Dim txtx, txty, txtxy, p As String
p = " "
txtxy = " 0.0000 0.0000" & vbCrLf
Dim i, l As Long
l = UBound(PointsX)
Dim x, x0 As Double
Dim y, y0 As Double
For i = 0 To l
Dim m As Integer
Dim mt As String
Dim dx, dy As Double
dx = PointsX(i)
dy = PointsY(i)
dx = dx / 100
dy = dy / 100
txtx = CStr(dx)
txty = CStr(dy)
m = Len(txtx) - InStr(1, txtx, “.”)
If m > 4 Then
txtx = Left(txtx, InStr(1, txtx, “.”) + 4)
End If
m = Len(txty) - InStr(1, txty, “.”)
If m > 4 Then
txty = Left(txty, InStr(1, txty, “.”) + 4)
End If
Dim probel As String
probel = " "
m = 14 - Len(txtx)
probel = Left(probel, m)
txtxy = txtxy & " " & txtx & probel & txty & vbCrLf
'txtxy = Replace(txtxy, “.”, “,”)
Next i
GetPointsTXT = txtxy & " 0.0000 0.0000"
End Function
Исправленная версия, в которой используется распознавание десятичных разделителей “.” или “,” в зависимости от настроек операционной системы.
А где можно скачать саму программу ? CNCFoamCut или она платная и ее надо купить ?