AnsweredAssumed Answered

Exporting coordinates from a point and transforming the coordinates from sketch to model

Question asked by Thomas Bryant on Feb 5, 2016
Latest reply on Feb 12, 2016 by Thomas Bryant

I would like to create a macro that finds multiple points from multiple 3d sketches and exports the data into a message box and Excel in model coordinates. I've tried various macros online, but none of them seem to compile due to various runtime errors.


I also tried the code in the below links but that did not work either:


Macro to capture points in 3d sketch and export to excel


I always get a "Runtime error 424: Object required" error (or similar ones), whether I try the code in the above link or my code below. Do I have to do something differently in SolidWorks 2016, or is it just overly complicated?


Option Explicit


Dim xlApp As Excel.Application


Dim xlWorkbook As Excel.Workbook


Public Function GetModelCoordinates _

( _

    swApp As SldWorks.SldWorks, _

    swPoint As SldWorks.MathPoint, _

    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 = SldWorks.MathTransform

    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 swMathUtil As SldWorks.MathUtility


    Dim swSelMgr As SldWorks.SelectionMgr


    Dim vPt1 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 DEC As Double


    Dim swSketch As SldWorks.Sketch


    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


    If Not swApp Is Nothing Then


        Set swModel = 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.GetSelectionPoint2(l, -1)


               If Not swPoint Is Nothing Then


                   Set swPoint = swPoint.GetPoint2


                   DEC = 6


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


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


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


                   vPt1 = dArr


                    vModelSelPt1 = GetModelCoordinates(swApp, swPoint, vPt1)


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


                    '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


startRow = 1


    For m = 1 To NumberOfSelectedItems


    For n = 1 To 3 Step 2


    With xlWorkbook.ActiveSheet


    startRow = (4 * m) + n - 2


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


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


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


    End With


    Next n


    Next m


            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


Thanks for any assistance!