VERSION 1.0 CLASS BEGIN MultiUse = -1 'True END Attribute VB_Name = "SVGFile" Attribute VB_GlobalNameSpace = False Attribute VB_Creatable = False Attribute VB_PredeclaredId = False Attribute VB_Exposed = False Dim ts As Scripting.TextStream Dim fs As New Scripting.FileSystemObject Dim indent As Integer Dim path As Long, layer As Long Dim CurrentLayer As String Dim CurrentPath As String Const PI As Double = 3.14159265358979 Const rad2deg As Double = 180 / 3.14159265358979 Const height As Double = 21 Const width As Double = 29.7 Const scalefac As Double = 1 Sub OpenFile(originX As Double, originY As Double) Set ts = fs.CreateTextFile("C:/temp/newfile.svg") writelineTS "" writelineTS "" writelineTS "", -width / 2, -height / 2 writelineTS "", -originX, originY, scalefac, -scalefac End Sub Sub Add_Layer(offset As Double) If CurrentLayer <> "" Then writelineTS "" CurrentLayer = "" End If layer = layer + 1 CurrentLayer = "layer_" & layer writelineTS "", CurrentLayer, Abs(offset * 10) End Sub Sub Add_Profile(profile As ProfilePath) Dim s As String Dim start As Point2d Dim P1 As Point2d, P2 As Point2d Dim i As Integer, j As Long Dim C As Object Dim cs As Double, sn As Double, rx As Double, ry As Double, an As Double '2D curves can be: 'kBSplineCurve2d 5256 'kCircleCurve2d 5252 'kCircularArcCurve2d 5253 'kEllipseFullCurve2d 5254 'kEllipticalArcCurve2d 5255 'kLineCurve2d 5250 'kLineSegmentCurve2d 5251 'kPolylineCurve2d 5257 'kUnknownCurve2d 5249 For i = 1 To profile.count Set C = profile.Item(i).Curve Select Case profile.Item(i).CurveType Case kBSplineCurve2d Dim m As Double, n As Double, count As Long Dim k() As Double, w() As Double, P() As Double C.Evaluator.GetEndPoints k(), w() openpath k(0), k(1) C.Evaluator.GetParamExtents m, n C.Evaluator.GetStrokes m, n, 0.001, count, k() writeTS " L " For j = 0 To count * 2 - 1 Step 2 writeTS " {1} {2} ", k(j), k(j + 1) Next Erase k, w, P ' This memory leak is hard to spot Case kCircleCurve2d closepath profile writeTS "" Case kCircularArcCurve2d openpath C.StartPoint.X, C.StartPoint.Y writeTS " A {1},{1} 0 ", C.Radius If C.SweepAngle < 0 Then If C.SweepAngle < -PI Then writeTS "1,0 " Else writeTS "0,0 " End If Else If C.SweepAngle > PI Then writeTS "1,1 " Else writeTS "0,1 " End If End If writeTS "{1},{2} ", C.EndPoint.X, C.EndPoint.Y Case kEllipseFullCurve2d closepath profile rx = C.MajorAxisVector.Length ry = C.MajorAxisVector.Length * C.MinorMajorRatio cs = C.MajorAxisVector.X / C.MajorAxisVector.Length sn = C.MajorAxisVector.Y / C.MajorAxisVector.Length writeTS "" Case kEllipticalArcCurve2d ' CHECK ME 'the elliptical arc has something funny about the start and end points Set C = profile.Item(i) openpath C.StartSketchPoint.Geometry.X, C.StartSketchPoint.Geometry.Y rx = C.Curve.MajorRadius ry = C.Curve.MinorRadius an = rad2deg * ArcTan2(C.Curve.MajorAxis.X, C.Curve.MajorAxis.Y) writeTS " A {1},{2} {3} ", rx, ry, an an = C.Curve.SweepAngle 'The curve sweep angle is wrong for negative angles, the API returns 2pi - angle If an < 0 Then If an > -PI Then writeTS "1,0 " Else writeTS "0,0 " End If Else If an > PI Then writeTS "1,1 " Else writeTS "0,1 " End If End If writeTS "{1},{2} ", C.EndSketchPoint.Geometry.X, C.EndSketchPoint.Geometry.Y 'Case kLineCurve2d ' START ME Case kLineSegmentCurve2d openpath C.StartPoint.X, C.StartPoint.Y writeTS "L {1} {2} ", C.EndPoint.X, C.EndPoint.Y 'Case kPolylineCurve2d 'START ME Case Else MsgBox "You need to add " & TypeName(C) Debug.Print TypeName(C) End End Select 'Try to avoid leaking memory Set C = Nothing Next closepath profile Set profile = Nothing End Sub Sub finish() Dim oFileDlg As FileDialog Dim fname As String If CurrentLayer <> "" Then writelineTS "" CurrentLayer = "" End If writelineTS "" ' Close the transform group ts.WriteLine "" ts.Close Call ThisApplication.CreateFileDialog(oFileDlg) oFileDlg.Filter = "SVG File (*.svg)" oFileDlg.DialogTitle = "Choose a filename" oFileDlg.InitialDirectory = "C:\Temp" oFileDlg.CancelError = True On Error Resume Next oFileDlg.ShowSave If Not Err Then fname = oFileDlg.FileName If fs.GetExtensionName(fname) <> "svg" Then fname = fname & ".svg" fs.CopyFile "C:\temp\newfile.svg", fname, True fs.DeleteFile "C:\temp\newfile.svg" End If On Error GoTo 0 bStop = True End Sub Private Sub openpath(startx As Double, starty As Double) If CurrentPath <> "" Then Exit Sub path = path + 1 CurrentPath = "path_" & path writelineTS "" End Sub Private Function writeTS(f As String, ParamArray t()) ' A simple version of printf for putting numbers into strings ' also replaces ' by "" to keep things legible Dim i As Integer For i = 0 To UBound(t) f = Replace$(f, "{" & i + 1 & "}", t(i)) Next f = Replace$(f, "'", """") If InStr(f, "") Then indent = indent - 3 End If ts.Write f If ts.Column > 120 Then ts.WriteLine ts.Write Space(indent) End If If InStr(f, "") Then indent = indent - 3 End If ts.WriteLine f If InStr(f, " 0 ArcTan2 = Atn(Y / X) Case Is < 0 ArcTan2 = Atn(Y / X) + PI * Sgn(Y) If Y = 0 Then ArcTan2 = ArcTan2 + PI Case Is = 0 ArcTan2 = PI / 2 * Sgn(Y) End Select End Function