thanks.
Il giorno lun 2 mar 2020 alle ore 15:30 andy pugh <[email protected]> ha
scritto:
> 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
>
_______________________________________________
Emc-users mailing list
[email protected]
https://lists.sourceforge.net/lists/listinfo/emc-users
