15 Replies Latest reply on Jan 16, 2017 11:57 PM by Arif Akbas

    auto dimensions macro

    Arif Akbas

      auto dimensions

      missing dimensions

      picture 1

       

      1.JPG

       

      picture 2

      I did not like the picture?

      Is it possible macro?

      add macro

       

      2.JPG

        • Re: auto dimensions macro
          Yong Ning

          Auto dimension with API. result is not good.

          Hand marked size effect is better

           

           

           

           

           

          123241q6p64a6cscs8q5bn.jpg

           

           

           

          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 swFeat As SldWorks.Feature

          Dim swSketch As SldWorks.Sketch

          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 = CreateObject("SldWorks.Application")

          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: auto dimensions macro
            Viktor Bovzdarenko

            Hi we have a couple of macro

            not sure if they match your requirements

            First one inserts overall dimensions:

            overall.PNG

            second one can insert hole dimension:

            hole.PNG

            here is the result of combination of 2 macro:

            overlap.PNG

            3rd macro runs "auto arrange dimensions" command :

            Autoarrange.PNG

            Unfortunately they do not handle slots and bending lines

            Please let me know if it is something which can interest you. I can add them fo free to #Task