4 Replies Latest reply on Jan 8, 2018 2:12 PM by Doug Seibel

    Single line font for engraving

    Mark Olsen

      Solidworks added a new single line font a few versions back.  Unfortunately, there is no way to project said sketch onto a non planar surface (at least that I know of).  So I created a macro to do it.  It requires a sketch with the lettering in it, and the lettering must be 'dissolved'.   Select the sketch, and all faces to project onto, run the macro and a 3D sketch on the faces is created.  It does work, but it's really slow.  Anyone have any ideas on how to make it faster?

       

      Thanks,

      Mark

       

      ' ProjectSketchOnSurfaces
      ' Written by Mark Olsen - 09/16/2015
      '
      ' Preconditions:
      '   A 2D sketch and one or more faces must be selected (in that order)
      '   The sketch must contain any sketch entities except blocks
      '       Note: If sketch plane intersects any selected face, output is
      '           unpredictable (especially if sketch segments intersect face).
      '
      ' Postconditions:
      '   A 3D sketch is created with each of the segments in the 2D sketch
      '       projected onto the selected faces.  The 3D sketch is completely
      '       unconstrained.
      '__________________________________________________________________________
      Option Explicit
      Dim swApp As SldWorks.SldWorks
      Sub main()
      Dim swModel As SldWorks.ModelDoc2
      Dim swSelMgr As SldWorks.SelectionMgr
      Dim swSketchMgr As SldWorks.SketchManager
      Dim vSegments As Variant
      Dim vSelSeg As Variant
      Dim swSketchSegment As SldWorks.SketchSegment
      Dim swSketch As SldWorks.Sketch
      Dim swFeature As SldWorks.Feature
      Dim swFeatMgr As SldWorks.FeatureManager
      Dim swPlane As Object
      Dim sSketchPlane As String
      Dim i As Integer
      Dim j As Integer
      Dim k As Integer

      On Error GoTo ErrorHandler:

      Set swApp = Application.SldWorks
      Set swModel = swApp.ActiveDoc
      Set swSelMgr = swModel.SelectionManager
      Set swSketchMgr = swModel.SketchManager
      Set swFeatMgr = swModel.FeatureManager

      swApp.CommandInProgress = True
      swSketchMgr.AddToDB = True

      'check for open part
      If swModel Is Nothing Then
          MsgBox "Nothing open.  Open a part and try again", vbOKOnly, "Error - No File"
          Exit Sub
      End If
      If Not swModel.GetType = 1 Then
          MsgBox "Not a part.  Open a part and try again", vbOKOnly, "Error - Not a part"
          Exit Sub
      End If
      'get sketch
      If Not swSelMgr.GetSelectedObjectType3(1, -1) = swSelSKETCHES Then
          MsgBox "First selection must be a sketch. Reselect entities", vbOKOnly, "Error - Not a sketch"
          Exit Sub
      End If

      'Suspend update of window
      Dim swModelView As SldWorks.ModelView
      Set swModelView = swModel.ActiveView
      swModelView.EnableGraphicsUpdate = False
      swFeatMgr.EnableFeatureTree = False
      swFeatMgr.EnableFeatureTreeWindow = False
      '========================

      Set swSketch = swSelMgr.GetSelectedObject(1).GetSpecificFeature2()
      Set swPlane = swSketch.GetReferenceEntity(swSelDATUMPLANES) 'Get sketch plane
      sSketchPlane = swPlane.Name

      Dim swFace As SldWorks.Face2
      Dim vFaces() As Variant
      Dim swbody As SldWorks.Body2

      For i = 2 To swSelMgr.GetSelectedObjectCount2(-1) ' Get selected faces
          If Not swSelMgr.GetSelectedObjectType3(i, -1) = 2 Then ' Check that selected objects (2 ->) are faces
              MsgBox "Selection" & i & " is not a face.  Select sketch to project, then faces to project onto.", _
                      vbOKOnly, "Error - Not a Face"
              Exit Sub
          End If
          ReDim Preserve vFaces(0 To i - 2)
          Set swFace = swSelMgr.GetSelectedObject6(i, -1)
          Set vFaces(i - 2) = swFace
      Next i

      Dim vCurves() As Variant
      Dim sCurveList() As String
      Dim sSketchList() As String

      vSegments = swSketch.GetSketchSegments
      j = 0: k = 0
      For Each vSelSeg In vSegments
          Set swSketchSegment = vSelSeg ' Create 2D sketch
          swModel.Extension.SelectByID2 sSketchPlane, "PLANE", 0, 0, 0, False, 0, Nothing, 0
          swSketchMgr.InsertSketch False
          swSketchSegment.Select4 False, Nothing
          swSketchMgr.SketchUseEdge2 (False)
          Set swFeature = swSketchMgr.ActiveSketch
          swSketchMgr.InsertSketch True
          ReDim Preserve sSketchList(0 To j)
          sSketchList(j) = swFeature.Name ' Build sketch list for later deletion
          j = j + 1
         
          For i = 0 To UBound(vFaces) ' Create Curves
              swSelMgr.AddSelectionListObject vFaces(i), Nothing
          Next i
          Set swFeature = swModel.InsertProjectedSketch2(0)
          If swFeature Is Nothing Then
              Set swFeature = swModel.InsertProjectedSketch2(1) ' If the sketch normal is the wrong way, reverse projection
          End If
          If Not swFeature Is Nothing Then ' If the curve isn't created (projection misses surface), don't add to the list
              ReDim Preserve vCurves(0 To k)
              ReDim Preserve sCurveList(0 To k)
              Set vCurves(k) = swFeature
              sCurveList(k) = swFeature.Name ' Build curve list for later deletion
              k = k + 1
          End If
      Next vSelSeg
      swModel.ClearSelection2 True

      For i = 0 To UBound(vCurves) ' Create 3D sketch from all curves
          swSelMgr.AddSelectionListObject vCurves(i), Nothing
      Next i
      swSketchMgr.Insert3DSketch False
      swSketchMgr.SketchUseEdge2 False
      Set swSketch = swSketchMgr.ActiveSketch
      vSegments = swSketch.GetSketchSegments
      For Each vSelSeg In vSegments
          vSelSeg.Select4 False, Nothing
      Next vSelSeg
      swModel.SketchConstraintsDelAll 'Delete all constraints
      swSketchMgr.Insert3DSketch False
      swModel.ClearSelection2 True

      For i = UBound(sCurveList) To 0 Step -1 ' Remove Curves - last to first
          swModel.Extension.SelectByID2 sCurveList(i), "REFCURVE", 0, 0, 0, True, 0, Nothing, 0
          swModel.DeleteSelection 2
      Next i
      swModel.ClearSelection2 True

      For i = UBound(sSketchList) To 0 Step -1 'Remove sketches - last to first
          swModel.Extension.SelectByID2 sSketchList(i), "SKETCH", 0, 0, 0, True, 0, Nothing, 0
          swModel.DeleteSelection 2
      Next i
      swModel.ClearSelection2 True

      swModelView.EnableGraphicsUpdate = True 'Restore update of window
      swFeatMgr.EnableFeatureTree = True
      swFeatMgr.EnableFeatureTreeWindow = True

      swSketchMgr.AddToDB = False

      'Error Handler
      Exit Sub
      ErrorHandler:
      swModelView.EnableGraphicsUpdate = True 'Restore update of window
      swFeatMgr.EnableFeatureTree = True
      swFeatMgr.EnableFeatureTreeWindow = True

      MsgBox "An error occured -  error  " & Err.Number & ": " & Err.Description

      End Sub

       

      BTW, anyone know how to post code so that the formatting and coloring doesn't get messed up?