AnsweredAssumed Answered

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

Question asked by Thomas Bryant on Feb 17, 2016
Latest reply on Feb 25, 2016 by 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:


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