6 Replies Latest reply on Feb 25, 2016 5:21 PM by Thomas Bryant

    Points in assembly files all export same or very similar XYZ coordinates when they shouldn't

    Thomas Bryant

      I have been working on a macros to export the values from a point (or multiple points). The macro works fine in a part file/2D sketch, but when I run the macro in an assembly file, the numbers that appear are always the same set of numbers (the ones shown below) regardless of which point I select. I've used these two references, but something is obviously still wrong:

       

      http://help.solidworks.com/2015/English/api/sldworksapi/Transform_Point_from_Component_Space_to_Assembly_Space_Example_VB.htm

       

      http://help.solidworks.com/2015/English/api/sldworksapi/Transform_Coordinates_from_Sketch_to_Model_Space_Example_VB.htm

       

      Even when trying a different assembly file, the numbers are still a slight variation of the ones shown (i.e. 3689 as the x-coordinate). Is there something else that needs changing? Here is my code so far, as well as example screenshots of the file I'm using and the output I get from it:

       

      Option Explicit

       

      Dim xlApp As Excel.Application

       

      Dim xlWorkbook As Excel.Workbook

       

      Public Function GetModelCoordinates _

      ( _

          swApp As SldWorks.SldWorks, _

          swSketch As SldWorks.Sketch, _

          vPtArr As Variant _

      ) As Variant

          Dim swMathPt As SldWorks.MathPoint

          Dim swMathUtil As SldWorks.MathUtility

          Dim swMathTrans As SldWorks.MathTransform

          Set swMathUtil = swApp.GetMathUtility

          Set swMathPt = swMathUtil.CreatePoint(vPtArr)

          Set swMathTrans = swSketch.ModelToSketchTransform

          Set swMathTrans = swMathTrans.Inverse

          Set swMathPt = swMathPt.MultiplyTransform(swMathTrans)

          GetModelCoordinates = swMathPt.ArrayData

       

      End Function

       

      Sub Main()

       

          'On Error Resume Next

       

          Dim swApp As SldWorks.SldWorks

       

          Dim swModel As SldWorks.ModelDoc2

        

          Dim swAssemblyDoc As AssemblyDoc

        

          Dim swPartDoc As PartDoc

       

          Dim swMathUtil As SldWorks.MathUtility

       

          Dim swSelMgr As SldWorks.SelectionMgr

       

          Dim swSketchLine As SldWorks.SketchLine

       

          Dim vPt1 As Variant

       

          Dim vPt2 As Variant

       

          Dim dArr(2) As Double

       

          Dim i As Long

       

          Dim j As Long

        

          Dim l As Long

        

          Dim m As Long

        

          Dim n As Long

       

          Dim dArrUnit As Variant

       

          Dim bRes As Boolean

       

          Dim Message As String

          Dim startRow As Double

       

          Dim swPoint As SldWorks.SketchPoint

       

          Dim NumberOfSelectedItems

       

          Dim swSelBody As SldWorks.Body2

        

          Dim vModelSelPt1 As Variant

        

          Dim vModelSelPt2 As Variant

        

          Dim vModelSelPt3 As Variant

        

          Dim vModelSelPt4 As Variant

        

          Dim DEC As Double

        

          Dim swSketch As SldWorks.Sketch

        

          Dim swComp As SldWorks.Component2

       

          Dim swXform As SldWorks.MathTransform

        

          Dim swPt As SldWorks.MathPoint

       

          Dim nPt(2) As Double

        

          Const UnitFactor As Double = 1000 'Get from m to mm

       

          Set swApp = Application.SldWorks

        

          Set swModel = swApp.ActiveDoc

        

          Set swSelMgr = swModel.SelectionManager

        

          Set swSketch = swModel.GetActiveSketch2

        

          Set swComp = swSelMgr.GetSelectedObjectsComponent(1)

        

          Set swXform = swComp.Transform2

        

          nPt(0) = 0#

       

          nPt(1) = 0#

       

          nPt(2) = 0#

       

          vPt1 = nPt

       

          If Not swApp Is Nothing Then

       

              Set swModel = swApp.ActiveDoc

            

              'Set swAssemblyDoc = swApp.ActiveDoc

       

              Set swMathUtil = swApp.GetMathUtility

       

              If Not swModel Is Nothing And Not swMathUtil Is Nothing Then

       

                  Set swSelMgr = swModel.SelectionManager

       

                  NumberOfSelectedItems = swSelMgr.GetSelectedObjectCount2(-1)

       

                  If NumberOfSelectedItems > 0 Then

       

                      'initialize Excel

       

                      Call GetExcel

       

                  End If

       

                  For l = 1 To NumberOfSelectedItems

       

                     Set swPoint = swSelMgr.GetSelectedObject6(l, -1)

                   

                      Set swPt = swMathUtil.CreatePoint(vPt1)

       

                      Set swPt = swPt.MultiplyTransform(swXform)

       

                     If Not swPoint Is Nothing And Not swPt Is Nothing Then

                   

                         'Set swSketch = swSketchLine.GetSketch

       

                         Set swSketch = swPoint.GetSketch

                       

                         DEC = 6

       

                         dArr(0) = FormatNumber(swPoint.X * UnitFactor, DEC)

       

                         dArr(1) = FormatNumber(swPoint.Y * UnitFactor, DEC)

       

                         dArr(2) = FormatNumber(swPoint.Z * UnitFactor, DEC)

       

                         vPt1 = dArr

        

                          vModelSelPt1 = GetModelCoordinates(swApp, swSketch, vPt1)

                        

                          'If swSelMgr.GetSelectedObjectType3(l, -1) = 1 Then

       

                              Message = Message & "Coordinates for Centerpoint is " & vbCrLf & "X: " & (vModelSelPt1(0)) & " mm" & " Y: " & (vModelSelPt1(1)) & " mm" & " Z: " & (vModelSelPt1(2)) & " mm" & vbCrLf

                        

                          'End If

       

                          'write two lines to Excel, so startrow is counted by 2

                        

                          bRes = WriteToExcel(((l - 1) * 2) + 1, vModelSelPt1, "Coordinates from Centerpoint")

       

                      End If

       

                  Next l

       

                  Set swSelMgr = Nothing

       

                  Set swPoint = Nothing

       

              End If

       

              Set swModel = Nothing

       

              Set swMathUtil = Nothing

       

          End If

       

      'show the message

       

      MsgBox Message

       

      End Sub

       

      Private Sub GetExcel()

       

          Set xlApp = CreateObject("Excel.Application")

       

          xlApp.Visible = True

       

          Set xlWorkbook = xlApp.Workbooks.Add

       

      End Sub

       

      Private Function WriteToExcel(startRow As Integer, data As Variant, Optional label As String = "") As Boolean

          'get the results into excel

          With xlWorkbook.ActiveSheet

        

              .Cells(startRow, 1).Value = "X"

       

              .Cells(startRow, 2).Value = "Y"

       

              .Cells(startRow, 3).Value = "Z"

       

              .Cells(startRow, 4).Value = label

       

              .Cells(startRow + 1, 1).Value = data(0)

       

              .Cells(startRow + 1, 2).Value = data(1)

       

              .Cells(startRow + 1, 3).Value = data(2)    

          End With

      End Function

      Coordinate results capture.PNG

       

      Assembly screenshot.PNG