I realise that this is of rather limited interest, but please forgive
me the few kB of inbox space.
Years ago I published a YouTube video showing slicing to an SVG file
from inside AutoDesk Inventor, and a link to the .ivb binary file.
Chatting on IRC it became evident that a plain-text version might be
more useful, so I am attaching it here, partly as a way to have it
archived and available.
--------------------SVGFile----------------------
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 "<?xml version='1.0' encoding='UTF-8' standalone='no'?>"
writelineTS "<svg"
writelineTS "xmlns='http://www.w3.org/2000/svg'"
writelineTS "xmlns:inkscape='http://www.inkscape.org/namespaces/inkscape'"
writelineTS "xmlns:slicer='http://www.bodgesoc.org'"
writelineTS "width='{1}cm'", width
writelineTS "height='{1}cm'", height
writelineTS "viewBox='{1} {2} {3} {4}'", -(width / 2), -height / 2,
width, height
writelineTS "version='1.1'"
writelineTS
"style='fill:#ffffff;fill-rule:evenodd;stroke-width:0px;fill-opacity:1'
>"
writelineTS "<rect style='fill:#000000;fill-opacity:1;stroke:none'
width='100%' height='100%' x='{1}' y='{2}' />", -width / 2, -height /
2
writelineTS "<g transform='translate({1},{2}) scale({3}, {4})'>",
-originX, originY, scalefac, -scalefac
End Sub
Sub Add_Layer(offset As Double)
If CurrentLayer <> "" Then
writelineTS "</g>"
CurrentLayer = ""
End If
layer = layer + 1
CurrentLayer = "layer_" & layer
writelineTS "<g inkscape:groupmode='layer' inkscape:label='{1}' ",
CurrentLayer
writelineTS "id='{1}' slicer:Z='{2}' >", 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 "<circle cx='{1}' cy='{2}' r='{3}' ", C.Center.X,
C.Center.Y, C.Radius
If profile.AddsMaterial = False Then writeTS "style='fill:#000000' "
writelineTS "/>"
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 "<ellipse cx='{1}' cy='{2}' rx='{3}' ry='{4}' ",
C.Center.X, C.Center.Y, rx, ry
'writeTS "transform='matrix({1},{2},{3},{4},0,0)'", cs, sn, -sn, cs
writeTS "transform='rotate({1},{2},{3})'", rad2deg *
ArcTan2(C.MajorAxisVector.X, C.MajorAxisVector.Y), C.Center.X,
C.Center.Y
If profile.AddsMaterial = False Then writeTS "style='fill:#000000' "
writelineTS "/>"
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 "</g>"
CurrentLayer = ""
End If
writelineTS "</g>" ' Close the transform group
ts.WriteLine "</svg>"
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 "<path id='{1}'", CurrentPath
writeTS "d='M {1} {2} ", startx, starty
End Sub
Private Sub closepath(profile As ProfilePath)
If CurrentPath = "" Then Exit Sub
CurrentPath = ""
writeTS " Z'"
If profile.AddsMaterial = False Then writeTS " style='fill:#000000' "
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, "</g>") 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, "<g") Or InStr(f, "<svg") Then
indent = indent + 3
End If
End Function
Private Function writelineTS(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, "</g>") Then
indent = indent - 3
End If
ts.WriteLine f
If InStr(f, "<g") Or InStr(f, "<svg") Then
indent = indent + 3
End If
ts.Write Space(indent)
End Function
Function ArcTan2(X As Double, Y As Double) As Double
Select Case X
Case Is > 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
--------------------Module1-----------------
Public Sub SliceToSVG()
Dim oActiveEnv As Environment
Set oActiveEnv = ThisApplication.UserInterfaceManager.ActiveEnvironment
If oActiveEnv.InternalName <> "PMxPartEnvironment" Then
MsgBox "This command can only run in an isolated part context
(at the moment at least)"
Exit Sub
End If
Dim oMiniToolbar As MiniToolbar
Set oMiniToolbar = ThisApplication.CommandManager.CreateMiniToolbar
oMiniToolbar.ShowOK = True
oMiniToolbar.ShowApply = False
oMiniToolbar.ShowCancel = True
Dim oControls As MiniToolbarControls
Set oControls = oMiniToolbar.Controls
oControls.Item("MTB_Options").Visible = False
Dim oDescriptionLabel As MiniToolbarControl
Set oDescriptionLabel = oControls.AddLabel("Description", "Slice
the part to SVG", "The intention is to drive a DLP")
oControls.AddNewLine
Dim oPlaneChooser As MiniToolbarButton
Set oPlaneChooser = oControls.AddButton("btnBasePlane", "Base
Plane:", "Pick the base plane to slice parallel to")
Dim oPlaneName As MiniToolbarControl
Set PlaneName = oControls.AddLabel("lblBasePlane", "
", "Press the button on the left to choose a plane")
oControls.AddNewLine
Dim oSliceThickness As MiniToolbarValueEditor
Set oSliceThickness = oControls.AddValueEditor("Thickness", "Enter
slice thickness (microns)", kLengthUnits, "microns")
oSliceThickness.Expression = "50"
' Set the position of mini-toolbar
Dim oPosition As Point2d
Set oPosition =
ThisApplication.TransientGeometry.CreatePoint2d(ThisApplication.ActiveView.Left,
ThisApplication.ActiveView.Top)
oMiniToolbar.Position = oPosition
oMiniToolbar.Visible = True
Dim oMiniToolbarEvents As New ClsToolbarEvents
Call oMiniToolbarEvents.Init(oMiniToolbar)
End Sub
-----------------ClsToolbarEvents----------------------------------
Public BasePlane As Object
Private WithEvents m_BasePlane As MiniToolbarButton
Private WithEvents m_Thickness As MiniToolbarValueEditor
Private m_BasePlaneName As MiniToolbarControl
Private WithEvents m_MiniToolbar As MiniToolbar
Private bStop As Boolean
Public Sub Init(oMiniToolbar As MiniToolbar)
Set m_MiniToolbar = oMiniToolbar
Set m_BasePlane = m_MiniToolbar.Controls.Item("btnBasePlane")
Set m_Thickness = m_MiniToolbar.Controls.Item("Thickness")
Set m_BasePlaneName = m_MiniToolbar.Controls.Item("lblBasePlane")
m_MiniToolbar.EnableOK = False
bStop = False
Do
ThisApplication.UserInterfaceManager.DoEvents
Loop Until bStop
End Sub
Private Sub m_BasePlane_OnClick()
Set BasePlane =
ThisApplication.CommandManager.Pick(kAllPlanarEntities, "Select start
plane or face")
If BasePlane Is Nothing Then Exit Sub
If TypeName(BasePlane) = "WorkPlane" Then
m_BasePlaneName.DisplayName = BasePlane.Name
Else
m_BasePlaneName.DisplayName = BasePlane.Parent.Name & ".Face"
End If
m_MiniToolbar.EnableOK = True
End Sub
Private Sub m_MiniToolbar_OnCancel()
bStop = True
End Sub
Private Sub m_MiniToolbar_OnOK()
SliceIt
End Sub
Private Sub SliceIt()
Dim oDoc As PartDocument
Set oDoc = ThisApplication.ActiveDocument
Dim oDef As PartComponentDefinition
Set oDef = oDoc.ComponentDefinition
Dim oSketch As PlanarSketch
Dim P As profile
Dim PP As ProfilePath
Dim nWP As WorkPlane
Dim i As Long
Dim SVG As New SVGFile
Dim ErrCount As Integer
Dim originX As Double, originY As Double
Dim P1 As Point2d, P2 As Point2d
Dim offset As Double, delta As Double
offset = 0
delta = m_Thickness.Expression / 10000
Set nWP = oDef.WorkPlanes.AddByPlaneAndOffset(BasePlane, delta)
Set oSketch = oDef.Sketches.Add(nWP, False)
'find model exxtents in the slice plane
Set P1 = oSketch.ModelToSketchSpace(oDef.RangeBox.MaxPoint)
Set P2 = oSketch.ModelToSketchSpace(oDef.RangeBox.MinPoint)
SVG.OpenFile (P1.X + P2.X) / 2, (P1.Y + P2.Y) / 2
'check the extrude direction
On Error Resume Next
oSketch.ProjectedCuts.Add
If Err <> 0 Then
delta = -delta
End If
'And now extrude
ErrCount = 0
While Not bStop
nWP.SetByPlaneAndOffset BasePlane, offset
Set oSketch = oDef.Sketches.Add(nWP, False)
On Error Resume Next
oSketch.ProjectedCuts.Add
oSketch.Profiles.AddForSolid
On Error GoTo 0
If oSketch.Profiles.count = 0 Then
ErrCount = ErrCount + 1
If ErrCount > 3 Then
nWP.Delete
bStop = True
SVG.finish
Exit Sub
End If
Else
DoEvents
SVG.Add_Layer (offset)
For Each P In oSketch.Profiles
For Each PP In P
SVG.Add_Profile PP
Set PP = Nothing
Next
Set P = Nothing
Next
End If
oSketch.Delete
Set oSketch = Nothing
offset = offset + delta
Wend
bStop = True
SVG.finish
End Sub
--
atp
"A motorcycle is a bicycle with a pandemonium attachment and is
designed for the especial use of mechanical geniuses, daredevils and
lunatics."
— George Fitch, Atlanta Constitution Newspaper, 1912
_______________________________________________
Emc-users mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/emc-users
