草图尺寸自动标注

家馨8883

   经典图书

  

图示尺寸标注是通过下面程序来实现的.

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

复制代码

fengan

谢谢楼主分享

5201314ggbb

   经典图书

原来如此！

607334

楼主太有才了，膜拜中……

lingqfjvu

   经典案例图书

好复杂呀，头看晕了

liuxiansheng75

感谢楼主分享，很不错！

zhjan518

   经典案例图书

其实就是完全定义草图而已

hocyoo

楼主太有才了，膜拜中……

超高的长颈鹿

怎么把程序弄到SW中使用呢？

lwqluo

   经典图书

谢谢分享，收下学习！

a33def

我是刚开始学的，这个不是本来就可以标注的吗？鼠标右键上移那个。。。

君子慎独

高人啊，只能是看看了

nusmud908

活到老学到老！

hui123

感谢楼主分享，很不错！

pjban2010

加入QQ群
参与讨论和学习

或扫描二维码加入

下载下来看看，应该会有用！

22669988

   经典案例图书

SolidWorks机械工程师网，顶一下。

aguolaode

加入QQ群
参与讨论和学习

或扫描二维码加入

好好学习，天天向上！

zhaoyichun

   经典案例图书

不错不错   很好

trulytry

xiazhengjian

厉害

yjsdyx

，来过