4 Replies Latest reply on Aug 19, 2015 6:14 AM by J. Legtenberg

    Macro only works near origin.

    J. Legtenberg

      Hello,

       

      I am working on a macro. I want to insert a sketch with my custom properties as text. After that, the sketch has to be renamed to "Gravering". When i click near the origin the name changes correct. If i click further away from the origin the name does not change.  The custom properties are "PARTNO" and "Revisie1". I also want to know if it is possible to check if there already is a sketch with the name "gravering"

       

      Here is my code:

       

      Dim swApp As Object

       

       

      Dim Part As Object

      Dim boolstatus As Boolean

      Dim longstatus As Long, longwarnings As Long

      Dim Point As Variant

       

       

      Sub main()

       

       

      Set swApp = Application.SldWorks

      Set Part = swApp.ActiveDoc

      Set SelMgr = Part.SelectionManager

         

      'Get xyz of seected face edge point etc.

      Point = SelMgr.GetSelectionPoint2(1, -1)

      'Print xyz

      Debug.Print "X= " & Point(0)

      Debug.Print "Y= " & Point(1)

      Debug.Print "Z= " & Point(2)

      'Print result of selecting component

      Debug.Print Part.Extension.SelectByID2("", "COMPONENT", Point(0), Point(1), Point(2), False, 0, Nothing, 0)

       

       

      Part.Extension.SelectByID2 "", "FACE", Point(0), Point(1), Point(2), False, 0, Nothing, 0

      Part.SketchManager.InsertSketch True

      Part.InsertSketchText Point(0), Point(1), Point(2), "$PRP:""PartNo""+$PRP:""Revisie1""", 0, 0, 0, 100, 100

      Part.ClearSelection2 True

      Part.SketchManager.InsertSketch True

      Part.ActivateSelectedFeature

      Part.Extension.SelectByID2 "", "SKETCH", 0, 0, 0, False, 0, Nothing, 0

      Part.SelectedFeatureProperties 0, 0, 0, 0, 0, 0, 0, 1, 0, "Gravering"

      End Sub

       

      Thanks!

        • Re: Macro only works near origin.
          Ivana Kolin
          Option Explicit
          Dim swApp As SldWorks.SldWorks
          
          
          Dim swModel As SldWorks.ModelDoc2
          Dim swPart As SldWorks.PartDoc
          Dim boolstatus As Boolean
          Dim longstatus As Long, longwarnings As Long
          Dim Point As Variant
          
          
          Sub main()
          Dim SelMgr As SldWorks.SelectionMgr
          Dim swSketch As SldWorks.Sketch
          Dim swSketchMgr As SldWorks.SketchManager
          Dim swFeat As SldWorks.Feature
          
          
          Set swApp = Application.SldWorks
          Set swModel = swApp.ActiveDoc
          Set swPart = swModel
          Set SelMgr = swModel.SelectionManager
          Set swFeat = swPart.FeatureByName("Gravering")
          If Not swFeat Is Nothing Then
              MsgBox "Gravering exists"
          End If
          'Get xyz of seected face edge point etc.
          Point = SelMgr.GetSelectionPoint2(1, -1)
          If IsEmpty(Point) Then
              Exit Sub
          End If
          'Print xyz
          Debug.Print "X= " & Point(0)
          Debug.Print "Y= " & Point(1)
          Debug.Print "Z= " & Point(2)
          'Print result of selecting component
          Debug.Print swModel.Extension.SelectByID2("", "COMPONENT", Point(0), Point(1), Point(2), False, 0, Nothing, 0)
          
          swModel.Extension.SelectByID2 "", "FACE", Point(0), Point(1), Point(2), False, 0, Nothing, 0
          Set swSketchMgr = swModel.SketchManager
          swSketchMgr.InsertSketch True
          Set swSketch = swSketchMgr.ActiveSketch
          Set swFeat = swSketch
          swFeat.Name = "Gravering"
          swModel.InsertSketchText Point(0), Point(1), Point(2), "$PRP:""PartNo""+$PRP:""Revisie1""", 0, 0, 0, 100, 100
          swModel.ClearSelection2 True
          swModel.SketchManager.InsertSketch True
          
          
          End Sub
          
            • Re: Macro only works near origin.
              J. Legtenberg

              Thank you for your quick reply.

               

              It works better now. When i want to insert the sketch it doesn't place the note at the selected place but in the middle of the selected face. This is not in every orientation but in a few orientations....

                • Re: Macro only works near origin.
                  Ivana Kolin

                  look at example in Solidworks API Help, you must use transformation

                   

                  Insert Sketch Text and Hole Example (VBA)

                    • Re: Macro only works near origin.
                      J. Legtenberg

                      I have combined the api help and the code above. Now it works great thank you!. ( yes i know that it maybe is a little bit too long).

                       

                      ' Preconditions: A model document is open and a face is selected.
                      ' Postconditions: The specified text and a hole are created on the
                      '                 face at the point of selection.
                          Option Explicit
                          Dim swApp As SldWorks.SldWorks
                          Dim swPart As SldWorks.PartDoc
                          Dim swModel As SldWorks.ModelDoc2
                          Dim swSelMgr As SldWorks.SelectionMgr
                          Dim eTapLocations(9) As Variant
                          Dim boolstatus As Boolean
                          Dim Point As Variant
                              Function TransformPoint(ByVal Sketch1 As Sketch, ByVal X As Double, ByVal Y As Double, ByVal Z As Double) As Variant
                          
                              Dim ptArr(2) As Double
                          
                              ptArr(0) = X
                              ptArr(1) = Y
                              ptArr(2) = Z
                              
                              Dim NewPt As Variant
                              Dim swMathUtil As SldWorks.MathUtility
                              Set swMathUtil = swApp.GetMathUtility
                              Dim swMathPt As SldWorks.MathPoint
                              Set swMathPt = swMathUtil.CreatePoint((ptArr))
                              Dim params As Variant
                          
                              params = swMathPt.ArrayData
                          
                              Dim swMathTrans As SldWorks.MathTransform
                              Set swMathTrans = Sketch1.ModelToSketchTransform
                              Set swMathPt = swMathPt.MultiplyTransform(swMathTrans)
                      
                      
                              NewPt = swMathPt.ArrayData()
                          
                              TransformPoint = NewPt
                          
                          End Function
                          Sub main()
                          Dim swSelMgr As SldWorks.SelectionMgr
                          Dim swFeat As SldWorks.Feature
                          Dim swSketch As SldWorks.Sketch
                          Dim selFace As Face2
                          Dim selEnt As Entity
                          Dim selPt As Variant
                          Dim selData As SldWorks.SelectData
                          Dim swSketchMgr As SldWorks.SketchManager
                          
                          Set swApp = Application.SldWorks
                          Set swModel = swApp.ActiveDoc
                          Set swSelMgr = swModel.SelectionManager
                          Set swFeat = swModel.FeatureByName("Gravering")
                         
                          Point = swSelMgr.GetSelectionPoint2(1, -1)
                          If Not swFeat Is Nothing Then
                              MsgBox "Gravering bestaat al."
                                  ElseIf IsEmpty(Point) Then
                                  MsgBox "Er is niets geselecteerd.", , "Selecteren"
                                  Exit Sub
                                      Else
                                          Set selFace = swSelMgr.GetSelectedObject6(1, -1)
                                          swSelMgr.GetSelectedObject6 1, -1
                                          Set selEnt = selFace
                                          selPt = swSelMgr.GetSelectionPoint2(1, -1)
                                       
                                          Set selData = swSelMgr.CreateSelectData
                                          
                                          selData.X = selPt(0)
                                          selData.Y = selPt(1)
                                          selData.Z = selPt(2)
                                             
                                          Set swSketchMgr = swModel.SketchManager
                                          
                                          swSketchMgr.InsertSketch True
                                          
                                          selPt = TransformPoint(swModel.IGetActiveSketch2, selPt(0), selPt(1), selPt(2))
                                          
                                          Set swSketchMgr = swModel.SketchManager
                                          Set swSketch = swSketchMgr.ActiveSketch
                                          Set swFeat = swSketch
                                          swFeat.Name = "Gravering"
                                      
                                          swModel.InsertSketchText selPt(0), selPt(1), selPt(2), "$PRP:""PartNo""+$PRP:""Revisie1""", 0, 0, 0, 100, 100
                                          swSketchMgr.InsertSketch True
                                          End If
                          End Sub