11 Replies Latest reply on Jan 11, 2017 11:59 AM by Deepak Gupta

    Macro Help

    David Johnson

      Hello,

       

      I came across this macro  on here a while back and am having a little trouble getting it to work, any help would be greatly appreciated

        • Re: Macro Help
          Deepak Gupta

          I've not tried your macro but try if the attached works. It is the same macro you've uploaded and I've updated the referenced only.

            • Re: Macro Help
              David Johnson

              Hi Deepak,

               

              I'm still getting the same error, at line 226 sSketchNameArr is highlighted as a compile error: ByRef argument type mismatch

               

              Thanks

                • Re: Macro Help
                  Deepak Gupta

                  Check now, have rearranged some lines.

                    • Re: Macro Help
                      David Johnson

                      i'm now getting: line 220 - Type mismatch

                       

                      Thanks for your help so far

                        • Re: Macro Help
                          Amen Allah Jlili

                          can you post the macro code? I don't have SW on this machine.

                            • Re: Macro Help
                              David Johnson

                              Option Explicit

                               

                               

                               

                               

                              Const swTnProfileFeature As String = "ProfileFeature"

                               

                               

                              Const nTolerance As Double = 0.00000001

                               

                               

                              Sub FindAllUnderConstrainedSketches(swApp As SldWorks.SldWorks, swModel As SldWorks.ModelDoc2, sSketchNameArr() As String)

                               

                               

                               

                               

                              Dim swPart As SldWorks.PartDoc

                              Dim swSketch As SldWorks.Sketch

                              Dim swFeat As SldWorks.Feature

                              Dim bRet As Boolean

                               

                               

                              Set swPart = swModel

                              Set swFeat = swPart.FirstFeature

                               

                               

                              Do While Not swFeat Is Nothing

                              If swTnProfileFeature = swFeat.GetTypeName Then

                              Set swSketch = swFeat.GetSpecificFeature2

                              If swUnderConstrained = swSketch.GetConstrainedStatus Then

                              sSketchNameArr(UBound(sSketchNameArr)) = swFeat.Name

                              ReDim Preserve sSketchNameArr(UBound(sSketchNameArr) + 1)

                              End If

                              End If

                              Set swFeat = swFeat.GetNextFeature

                              Loop

                              ' Remove last empty sketch name

                              ReDim Preserve sSketchNameArr(UBound(sSketchNameArr) - 1)

                              End Sub

                               

                               

                              Function GetAllSketchLines( _

                              swApp As SldWorks.SldWorks, _

                              swModel As SldWorks.ModelDoc2, _

                              swSketch As SldWorks.Sketch) As Variant

                              Dim vSketchSegArr As Variant

                              Dim vSketchSeg As Variant

                              Dim swSketchSeg As SldWorks.SketchSegment

                              Dim swSketchCurrLine As SldWorks.SketchLine

                              Dim swSketchLineArr() As SldWorks.SketchLine

                              ReDim swSketchLineArr(0)

                              vSketchSegArr = swSketch.GetSketchSegments

                              If Not IsEmpty(vSketchSegArr) Then

                              For Each vSketchSeg In vSketchSegArr

                              Set swSketchSeg = vSketchSeg

                              If swSketchLINE = swSketchSeg.GetType Then

                              Set swSketchCurrLine = swSketchSeg

                              Set swSketchLineArr(UBound(swSketchLineArr)) = swSketchCurrLine

                              ReDim Preserve swSketchLineArr(UBound(swSketchLineArr) + 1)

                              End If

                              Next

                              End If

                              If 0 = UBound(swSketchLineArr) Then

                              ' No straight lines in this sketch

                              GetAllSketchLines = Empty

                              Exit Function

                              End If

                              ' Remove last empty sketch line

                              ReDim Preserve swSketchLineArr(UBound(swSketchLineArr) - 1)

                              GetAllSketchLines = swSketchLineArr

                              End Function

                              Function GetSketchPoint( _

                              swApp As SldWorks.SldWorks, _

                              swModel As SldWorks.ModelDoc2, _

                              swSketch As SldWorks.Sketch, _

                              swSketchPt As SldWorks.SketchPoint) As Boolean

                              Dim vSketchPtArr As Variant

                              vSketchPtArr = swSketch.GetSketchPoints

                              If Not IsEmpty(vSketchPtArr) Then

                              ' Use first point

                              Set swSketchPt = vSketchPtArr(0)

                              GetSketchPoint = True

                              Exit Function

                              End If

                              GetSketchPoint = False

                              End Function

                              Function FindVerticalOrigin( _

                              swApp As SldWorks.SldWorks, _

                              swModel As SldWorks.ModelDoc2, _

                              swSketch As SldWorks.Sketch, _

                              swSketchSegVert As SldWorks.SketchSegment, _

                              swSketchPtVert As SldWorks.SketchPoint) As Boolean

                              Dim vSketchLineArr As Variant

                              Dim vSketchLine As Variant

                              Dim swSketchCurrLine As SldWorks.SketchLine

                              Dim swStartPt As SldWorks.SketchPoint

                              Dim swEndPt As SldWorks.SketchPoint

                              ' Try to get first vertical line

                              vSketchLineArr = GetAllSketchLines(swApp, swModel, swSketch)

                              If Not IsEmpty(vSketchLineArr) Then

                              For Each vSketchLine In vSketchLineArr

                              Set swSketchCurrLine = vSketchLine

                              Set swStartPt = swSketchCurrLine.GetStartPoint2

                              Set swEndPt = swSketchCurrLine.GetEndPoint2

                              If Abs(swStartPt.X - swEndPt.X) < nTolerance Then

                              Set swSketchSegVert = swSketchCurrLine

                              FindVerticalOrigin = True

                              Exit Function

                              End If

                              Next

                              End If

                              ' Try to get the first point

                              FindVerticalOrigin = GetSketchPoint(swApp, swModel, swSketch, swSketchPtVert)

                              End Function

                              Function FindHorizontalOrigin( _

                              swApp As SldWorks.SldWorks, _

                              swModel As SldWorks.ModelDoc2, _

                              swSketch As SldWorks.Sketch, _

                              swSketchSegHoriz As SldWorks.SketchSegment, _

                              swSketchPtHoriz As SldWorks.SketchPoint) As Boolean

                              Dim vSketchLineArr As Variant

                              Dim vSketchLine As Variant

                              Dim swSketchCurrLine As SldWorks.SketchLine

                              Dim swStartPt As SldWorks.SketchPoint

                              Dim swEndPt As SldWorks.SketchPoint

                              ' Try to get first horizontal line

                              vSketchLineArr = GetAllSketchLines(swApp, swModel, swSketch)

                              If Not IsEmpty(vSketchLineArr) Then

                              For Each vSketchLine In vSketchLineArr

                              Set swSketchCurrLine = vSketchLine

                              Set swStartPt = swSketchCurrLine.GetStartPoint2

                              Set swEndPt = swSketchCurrLine.GetEndPoint2

                              If Abs(swStartPt.Y - swEndPt.Y) < nTolerance Then

                              Set swSketchSegHoriz = swSketchCurrLine

                              FindHorizontalOrigin = True

                              Exit Function

                              End If

                              Next

                              End If

                              ' Try to get the first point

                              FindHorizontalOrigin = GetSketchPoint(swApp, swModel, swSketch, swSketchPtHoriz)

                              End Function

                               

                               

                              Function AutoDimensionSketch( _

                              swApp As SldWorks.SldWorks, _

                              swModel As SldWorks.ModelDoc2, _

                              swSketch As SldWorks.Sketch) As Long

                              Dim swFeat As SldWorks.Feature

                              Dim swSketchSegHoriz As SldWorks.SketchSegment

                              Dim swSketchPtHoriz As SldWorks.SketchPoint

                              Dim swSketchSegVert As SldWorks.SketchSegment

                              Dim swSketchPtVert As SldWorks.SketchPoint

                              Dim bRet As Boolean

                              If False = FindHorizontalOrigin(swApp, swModel, swSketch, swSketchSegHoriz, swSketchPtHoriz) Then

                              AutoDimensionSketch = swAutodimStatusDatumLineNotHorizontal

                              Exit Function

                              End If

                              If False = FindVerticalOrigin(swApp, swModel, swSketch, swSketchSegVert, swSketchPtVert) Then

                              AutoDimensionSketch = swAutodimStatusDatumLineNotVertical

                              Exit Function

                              End If

                              Set swFeat = swSketch

                              bRet = swFeat.Select2(False, 0)

                              Debug.Assert bRet

                              ' Editing sketch clears selections

                              swModel.EditSketch

                              ' Reselect sketch segments for autodimensioning

                              If Not swSketchSegVert Is Nothing Then

                              ' Vertical line is for horizontal datum

                              bRet = swSketchSegVert.Select4(True, Nothing)

                              ElseIf Not swSketchPtHoriz Is Nothing Then

                              bRet = swSketchPtHoriz.Select4(True, Nothing)

                              ElseIf Not swSketchPtVert Is Nothing Then

                              ' Use any sketch point for horizontal datum

                              bRet = swSketchPtVert.Select4(True, Nothing)

                              End If

                              Debug.Assert bRet

                              If Not swSketchSegHoriz Is Nothing Then

                              ' Horizontal line is for vertical datum

                              bRet = swSketchSegHoriz.Select4(True, Nothing)

                              ElseIf Not swSketchPtVert Is Nothing Then

                              bRet = swSketchPtVert.Select4(True, Nothing)

                              ElseIf Not swSketchPtHoriz Is Nothing Then

                              ' Use any sketch point for vertical datum

                              bRet = swSketchPtHoriz.Select4(True, Nothing)

                              End If

                              Debug.Assert bRet

                              ' No straight lines, probably contains circles,

                              ' so use sketch points for datums

                              If IsEmpty(GetAllSketchLines(swApp, swModel, swSketch)) Then

                              If Not swSketchPtHoriz Is Nothing Then

                              bRet = swSketchPtHoriz.Select4(False, Nothing)

                              ElseIf Not swSketchPtVert Is Nothing Then

                              bRet = swSketchPtVert.Select4(False, Nothing)

                              End If

                              End If

                              Debug.Assert bRet

                              AutoDimensionSketch = swSketch.AutoDimension2(swAutodimEntitiesAll, _

                              swAutodimSchemeBaseline, _

                              swAutodimHorizontalPlacementBelow, _

                              swAutodimSchemeBaseline, _

                              swAutodimVerticalPlacementLeft)

                              ' Redraw so dimensions are displayed immediately

                              swModel.GraphicsRedraw2

                              ' Exit sketch edit

                              ' Leave rebuild to later

                              swModel.InsertSketch2 False

                              End Function

                               

                               

                               

                               

                              Sub main()

                               

                               

                              Dim swApp As SldWorks.SldWorks

                              Dim swModel As SldWorks.ModelDoc2

                              Dim swPart As SldWorks.PartDoc

                              Dim sSketchNameArr() As String

                              Dim sSketchName As Variant

                              Dim swFeat As SldWorks.Feature

                              Dim swSketch As SldWorks.Sketch

                              Dim nRetVal As Long

                              Dim i As Long

                              Dim bRet As Boolean

                               

                               

                               

                               

                              Set swApp = Application.SldWorks

                              Set swModel = swApp.ActiveDoc

                              Set swPart = swModel

                              Debug.Print "File = " & swModel.GetPathName

                              ReDim sSketchNameArr(0)

                              FindAllUnderConstrainedSketches swApp, swModel, sSketchNameArr

                              For Each sSketchName In sSketchNameArr

                              Set swFeat = swPart.FeatureByName(sSketchName)

                              Set swSketch = swFeat.GetSpecificFeature

                              nRetVal = AutoDimensionSketch(swApp, swModel, swSketch)

                              Debug.Print " " & sSketchName & " = " & nRetVal

                              Next

                              ' Rebuild after modifying sketches

                              bRet = swModel.EditRebuild3

                              Debug.Assert bRet

                               

                               

                               

                               

                              End Sub

                            • Re: Macro Help
                              Deepak Gupta

                              Are you running it on a part file?

                      • Re: Macro Help
                        Amen Allah Jlili

                        it looks to me that this macro is a modified version of this