SolidWorks机械工程师网——最大的SolidWorks学习平台

 保存到相册

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

试用了楼主的程序,功能十分强大!由衷的佩服,在下也想利用宏实现一个小功能,但却无从下手,求助于前辈!