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

 找回密码
 立即注册

QQ登录

只需一步,快速开始

好品数字
好品数字
查看: 5647|回复: 41

草图尺寸自动标注

  [复制链接]

12

主题

206

帖子

23

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
230
发表于 2011-10-21 12:36:56 | 显示全部楼层 |阅读模式
  
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

复制代码
SolidWorks机械工程师网
提示:建议使用谷歌浏览器浏览本网站!如单击这里下载!否则,可能无法下载附件文件!(支持大多数版本的谷歌浏览器,支持10、11两个版本的IE浏览器,支持360和QQ浏览器的极速模式,即谷歌内核模式,以及10和11版本的IE兼容模式,其余浏览器也是如此)
回复

使用道具 举报

16

主题

206

帖子

39

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
262
QQ
发表于 2011-10-21 12:39:29 | 显示全部楼层
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
  Debug.Print wTnProfileFeature, swFeat.GetTypeName
If swTnProfileFeature = swFeat.GetTypeName Then
Set swSketch = swFeat.GetSpecificFeature2
   Debug.Print swUnderConstrained, swSketch.GetConstrainedStatus
If swUnderConstrained = swSketch.GetConstrainedStatus Then
sSketchNameArr(UBound(sSketchNameArr)) = swFeat.Name
  Debug.Print 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
----
运行结果
File =
              DetailCabinet
              CommentsFolder
              DocsFolder
              SurfaceBodyFolder
              SolidBodyFolder
              MaterialFolder
              EnvFolder
              RefPlane
              RefPlane
              RefPlane
              OriginProfileFeature
              ProfileFeature
2             3
              ProfileFeature
2             2
草图5
              ProfileFeature
2             2
草图6
SolidWorks机械工程师网
提示:建议使用谷歌浏览器浏览本网站!如单击这里下载!否则,可能无法下载附件文件!(支持大多数版本的谷歌浏览器,支持10、11两个版本的IE浏览器,支持360和QQ浏览器的极速模式,即谷歌内核模式,以及10和11版本的IE兼容模式,其余浏览器也是如此)
回复 支持 反对

使用道具 举报

10

主题

206

帖子

30

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
244
QQ
发表于 2011-10-21 12:41:18 | 显示全部楼层
能否自动标注,这个问题不重要,重要的是标注首先要符合GB。希望能看看到关于按GB标注的二次开发
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

15

主题

251

帖子

50

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
313
QQ
发表于 2011-10-21 12:43:24 | 显示全部楼层
SW的标注真不理想!!
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

13

主题

235

帖子

26

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
287
QQ
发表于 2011-10-21 12:43:25 | 显示全部楼层

   经典案例图书
不错啊!我也试试看
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

12

主题

230

帖子

24

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
268
QQ
发表于 2011-10-21 12:44:47 | 显示全部楼层
希望能做到和楼主一样
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

83

主题

282

帖子

157

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
439
发表于 2011-10-21 12:44:57 | 显示全部楼层

   经典案例图书
偶是新手    楼主能不能教教怎么把程序弄到SW中使用啊?
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

82

主题

312

帖子

168

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
495
QQ
发表于 2011-10-21 12:45:06 | 显示全部楼层
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

14

主题

231

帖子

34

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
276
QQ
发表于 2011-10-21 12:46:51 | 显示全部楼层
真是牛人呀,为了个标注这么折腾
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

12

主题

256

帖子

31

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
317
QQ
发表于 2011-10-21 12:48:02 | 显示全部楼层
怎么把程序弄到SW中使用啊?
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

12

主题

250

帖子

45

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
322
QQ
发表于 2011-10-21 12:48:23 | 显示全部楼层
人类太强大了
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

77

主题

293

帖子

299

金币

堂主

Rank: 4

积分
600

最佳新人活跃会员热心会员灌水之王

发表于 2011-10-21 12:48:38 | 显示全部楼层
真不错,赞一个,继续努力啊
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

10

主题

256

帖子

36

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
310
QQ
发表于 2011-10-21 12:55:31 | 显示全部楼层
楼主真牛!
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

11

主题

234

帖子

33

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
291
QQ
发表于 2011-10-21 12:55:43 | 显示全部楼层
API帮助中的一个例子而已,楼主能给贴出也是一个进步,但要说明为好。
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

16

主题

209

帖子

28

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
258
QQ
发表于 2011-10-21 12:55:43 | 显示全部楼层
加入QQ群
参与讨论和学习

SolidWorks技术交流群

或扫描二维码加入

感觉SolidWorks中的自动标注不人性化......
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

13

主题

244

帖子

36

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
293
QQ
发表于 2011-10-21 12:56:06 | 显示全部楼层

   经典案例图书
希望能做到和楼主一样
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

9

主题

216

帖子

17

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
236
发表于 2011-10-21 12:57:05 | 显示全部楼层
加入QQ群
参与讨论和学习

SolidWorks技术交流群

或扫描二维码加入

怎么把程序弄到SW中使用啊?
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

10

主题

209

帖子

26

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
248
QQ
发表于 2011-10-21 12:57:11 | 显示全部楼层

   经典案例图书
试用了楼主的程序,功能十分强大!由衷的佩服,在下也想利用实现一个小功能,但却无从下手,求助于前辈!
1.针对装配图档和零件图档
2.点击或执行,自动将 各个零件 文件-属性-信息摘要  里的

"sheet name" "Description" "Material"  属性名称和评估的值输出到excel中的前三行(并最好自动打开excel文件).
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

12

主题

217

帖子

23

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
269
QQ
发表于 2011-10-21 12:57:18 | 显示全部楼层
不错不错   很好
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

13

主题

209

帖子

26

金币

侠客

Rank: 3Rank: 3Rank: 3

积分
256
QQ
发表于 2011-10-21 12:58:40 | 显示全部楼层
敢问楼主是学的机械数字化方向的大师吗?
SolidWorks机械工程师网
回复 支持 反对

使用道具 举报

您需要登录后才可以回帖 登录 | 立即注册

本版积分规则

关闭 卷起
关闭 卷起

手机版|小黑屋| GMT+8, 2024-3-29 23:37 , Processed in 0.196316 second(s), 41 queries .

SolidWorks机械工程师网 ( 鲁ICP备14025122号-2 ) 鲁公网安备 37028502190335号

声明:本网言论纯属发表者个人意见,与本网立场无关。
如涉版权,可发邮件: admin@swbbsc.com

快速回复 返回顶部 返回列表