Can the Measure Routine Report Dual Dimensions? 1

[brengine]

Can the Measure Routine Report Dual Dimensions? I get tired of switiching between the 2 (our parts, customer parts, and purchased parts are always different somewhere 8(

 

[dsi]

If you are interested, this could be done relatively easily with a macro. I may have some time today to whip one up for you. What do you measure? Lengths of edges and lines? Areas of surfaces? etc... DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.

 

[dsi]

Well, I did not have that much time to add a ton of options, but this will measure and report measurements for Edges that are lines or circles. I also assumed you want to see inches and millimeters. This may be tough to read because of the width, so feel free to e-mail me and I'll send you the swp file. If you need more features, I can add them as time permits.

Option Explicit

Const dPi = 3.141592654
Const MtoIN = 1 / 0.0254
Const MtoMM = 1000
Const M2toIN2 = 1550.003
Const M2toMM2 = 1000000

Const swSelEDGES = 1

Const swMbInformation = 2
Const swMbStop = 4
Const swMbOk = 2

Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swSelMgr As SelectionMgr
Dim swEdge As Edge
Dim swCurve As Curve

Dim lngSelType As Long
Dim pt1 As Double
Dim pt2 As Double
Dim bVal1 As Boolean
Dim bVal2 As Boolean
Dim vSafeArray As Variant
Dim dLen As Double

Sub main()
    Dim sMsg As String
    Set swApp = CreateObject("SldWorks.Application")
    Set swModel = swApp.ActiveDoc
    Set swSelMgr = swModel.SelectionManager
    If swSelMgr.GetSelectedObjectCount <> 1 Then
        swApp.SendMsgToUser2 &quot;Please Select ONE Edge to Measure&quot;, swMbStop, swMbOk
        GoTo CleanUp
    End If
    lngSelType = swSelMgr.GetSelectedObjectType2(1)
    If lngSelType = swSelEDGES Then
        Set swEdge = swSelMgr.GetSelectedObject3(1)
        Set swCurve = swEdge.GetCurve
        If swCurve.IsLine Then
            Call swCurve.GetEndParams(pt1, pt2, bVal1, bVal2)
            dLen = swCurve.GetLength2(pt1, pt2)
            sMsg = &quot;Selected Edge - Line&quot; & vbCrLf & vbCrLf & _
                   &quot;Length (in): &quot; & Format(dLen * MtoIN, &quot;##,##0.00000&quot;) & vbCrLf & _
                   &quot;Length (mm): &quot; & Format(dLen * MtoMM, &quot;###,##0.000&quot;)
        ElseIf swCurve.IsCircle Then
            vSafeArray = swCurve.CircleParams
            sMsg = &quot;Selected Edge - Circle:&quot; & vbCrLf & vbCrLf & _
                   &quot;Center (in): (&quot; & Format(vSafeArray(0) * MtoIN, &quot;##,##0.0000&quot;) & _
                   &quot;, &quot; & Format(vSafeArray(1) * MtoIN, &quot;##,##0.0000&quot;) & _
                   &quot;, &quot; & Format(vSafeArray(2) * MtoIN, &quot;##,##0.0000&quot;) & &quot;)&quot; & vbCrLf & _
                   &quot;Daimeter (in): &quot; & Format(vSafeArray(6) * 2 * MtoIN, &quot;##,##0.0000&quot;) & vbCrLf & _
                   &quot;Circumference (in): &quot; & Format(2 * dPi * vSafeArray(6) * MtoIN, &quot;##,##0.0000&quot;) & vbCrLf & _
                   &quot;Area (in^2): &quot; & Format(dPi * vSafeArray(6) ^ 2 * M2toIN2, &quot;##,##0.0000&quot;) & vbCrLf & vbCrLf & _
                   &quot;Center (mm): (&quot; & Format(vSafeArray(0) * MtoMM, &quot;##,##0.000&quot;) & _
                   &quot;, &quot; & Format(vSafeArray(1) * MtoMM, &quot;##,##0.000&quot;) & _
                   &quot;, &quot; & Format(vSafeArray(2) * MtoMM, &quot;##,##0.000&quot;) & &quot;)&quot; & vbCrLf & _
                   &quot;Daimeter (mm): &quot; & Format(vSafeArray(6) * 2 * MtoMM, &quot;##,##0.000&quot;) & vbCrLf & _
                   &quot;Circumference (mm): &quot; & Format(2 * dPi * vSafeArray(6) * MtoMM, &quot;##,##0.000&quot;) & vbCrLf & _
                   &quot;Area (mm^2): &quot; & Format(dPi * vSafeArray(6) ^ 2 * M2toMM2, &quot;##,##0.000&quot;)
        Else
            swApp.SendMsgToUser2 &quot;Edge Must be a Line or a Circle&quot;, swMbStop, swMbOk
            GoTo CleanUp
        End If
    Else
        swApp.SendMsgToUser2 &quot;I can only measure Edges&quot;, swMbStop, swMbOk
    End If
    swApp.SendMsgToUser2 sMsg, swMbInformation, swMbOk
CleanUp:
    Set swEdge = Nothing
    Set swCurve = Nothing
    Set swSelMgr = Nothing
    Set swModel = Nothing
    Set swApp = Nothing
End Sub

DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.

 

[brengine]

Thanks! I'll give it a try. The only other thing I can think of would be to measure the distance between parallel planes/faces.

 

[dsi]

Sorry for the delay. This macro will measure the distance between two parallel faces, reporting the result in inches and millimeters. If you want me to send you the file, just e-mail me.

Option Explicit

Const swSelFACES = 2

Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swFace1 As face2
Dim swFace2 As face2
Dim swSurface1 As surface
Dim swSurface2 As surface
Dim swSelMgr As SelectionMgr

Sub main()
    Dim vSelectionPt1 As Variant
    Dim vSelectionPt2 As Variant
    Dim vClosestPt1 As Variant
    Dim vClosestPt2 As Variant
    Dim dDistance1 As Double
    Dim dDistance2 As Double
    Dim lSelType1 As Long
    Dim lSelType2 As Long
    Dim dX As Double
    Dim dY As Double
    Dim dZ As Double
    Dim sMsg As String
    
    Set swApp = CreateObject("Sldworks.Application")
    Set swModel = swApp.ActiveDoc
    
    Set swSelMgr = swModel.SelectionManager
    
    lSelType1 = swSelMgr.GetSelectedObjectType2(1)
    lSelType2 = swSelMgr.GetSelectedObjectType2(2)
    
    If lSelType1 <> swSelFACES Or lSelType2 <> swSelFACES Then
        swApp.SendMsgToUser &quot;Please Select 2 Faces&quot;
        GoTo CleanUp
    End If
    
    Set swFace1 = swSelMgr.GetSelectedObject3(1)
    Set swFace2 = swSelMgr.GetSelectedObject3(2)

    Set swSurface1 = swFace1.GetSurface
    Set swSurface2 = swFace2.GetSurface

    vSelectionPt1 = swSelMgr.GetSelectionPoint(1)
    vSelectionPt2 = swSelMgr.GetSelectionPoint(2)

    vClosestPt1 = swSurface1.GetClosestPointOn(vSelectionPt2(0), vSelectionPt2(1), vSelectionPt2(2))
    vClosestPt2 = swSurface2.GetClosestPointOn(vSelectionPt1(0), vSelectionPt1(1), vSelectionPt1(2))
    
    dX = vSelectionPt1(0) - vClosestPt2(0)
    dY = vSelectionPt1(1) - vClosestPt2(1)
    dZ = vSelectionPt1(2) - vClosestPt2(2)
    dDistance1 = Sqr(dX ^ 2 + dY ^ 2 + dZ ^ 2)
    
    dX = vSelectionPt2(0) - vClosestPt1(0)
    dY = vSelectionPt2(1) - vClosestPt1(1)
    dZ = vSelectionPt2(2) - vClosestPt1(2)
    dDistance2 = Sqr(dX ^ 2 + dY ^ 2 + dZ ^ 2)
    
    If Abs(dDistance1 - dDistance2) <= 0.0001 Then  'Close enough to parallel
        sMsg = &quot;Distance = &quot; & Format((dDistance1 * 39.37008), &quot;#,##0.00000&quot;) & &quot; inches&quot; & vbCrLf & _
               Space(18) & Format((dDistance1 * 1000), &quot;##,##0.0000&quot;) & &quot; mm&quot;
    Else
         sMsg = &quot;Selected Faces are NOT Parallel&quot;
    End If
    swApp.SendMsgToUser sMsg
    
CleanUp:
    Set swFace1 = Nothing
    Set swFace2 = Nothing
    Set swSurface1 = Nothing
    Set swSurface2 = Nothing
    Set swSelMgr = Nothing
    Set swModel = Nothing
    Set swApp = Nothing
End Sub

DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.

 

[brengine]

dsi,
Thanks for the help. The Edge Measurement Macro worked great once I changed your variable declarations:
Dim swApp As SldWorks.SldWorks
Dim swModel As ModelDoc2
Dim swSelMgr As SelectionMgr
Dim swEdge As Edge
Dim swCurve As Curve

to:
Dim swApp As Object
Dim swModel As Object
Dim swSelMgr As Object
Dim swEdge As Object
Dim swCurve As Object

I did likewise on the Distance Between Parallel Faces Macro, but it still didn't work. I kept getting a "Faces NOT Parallel" error message. I'll mess with it but I think this one is over my head.

Thanks for the help, this is a learning experience as well as helpful tool for me to use.
Ken

 

[dsi]

Forgot to mention that the early bining used in the code requires that you add the SldWrks Object Library to the VBA References (Tools > References).

Not sure why it wouldn't be working. You may want to echo back the tolerance check to see if they are slightly off of parallel. Just let me know. DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.

 

[dogarila]

dsi, I tried the Distance Between Parallel Faces Macro and kept getting the same message as Ken.

Andrew

 

[brengine]

dsi,
I have an example assembly that measures 13.5" between parallel parts with the normal Measure Routine in the X direction.

While I step thru this Macro in VB-Solidworks (hitting [F8] for each step) I followed the variable values in the Locals Window, and all the reported X, Y, & Z values are all different. The X values should be 13.5" apart, but they're different. Also the vClosestPt1 and vClosestPt2 report 5 values in the Array rather than only 3 (if that means anything).

I couldn't find a References under the Tools Menu to turn it on, so maybe that is my problem.

Thanks for all your efforts, hope I haven't used too much of your time,
Ken

 

[dsi]

I will look into it again.

The References are under the Tools menu in the VBA Editor. In there, you will find the SldWorks Object Library. It allows you to early bind your code, giving you a dropdown list of properties and methods for your objects as you type.

For example, if early bound, you could type:

swApp.

and up would come a list containing the methods and properties available for the SldWorks.SldWorks object. Play with it a bit, it makes coding a lot easier. DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.

 

[dsi]

Looks like it only works for parts. When I have some more time, I can investigate it further. DimensionalSolutions@Core.com
While I welcome e-mail messages, please post all thread activity in these forums for the benefit of all members.