版大的自动结合宏（转来收藏的）

frank0227 · 发表于 2013-6-10 09:22:45

经典图书

大侠的自动结合宏（转来收藏的）论坛好像没有

Macros.zip (23.97 KB, 下载次数: 75)

fire_fun · 发表于 2013-6-10 09:24:31

SW总会碰到许多稀奇古怪的问题，还好有这么多热心人

liu_hlxrcm · 发表于 2013-6-10 09:33:23

经典图书

感謝工程师製作，也感謝樓主分享

jyzas001 · 发表于 2017-8-12 11:35:29

附件损坏打不开

sunmulei · 发表于 2017-8-29 21:08:29

经典案例图书

加入QQ群
参与讨论和学习
SolidWorks技术交流群
或扫描二维码加入
SW总会碰到许多稀奇古怪的问题，还好有这么多热心人

384432485 · 发表于 2018-4-29 17:06:55

楼主辛苦了！

LYCZJS · 发表于 2018-5-21 21:16:04

经典案例图书

SW机械工程师论坛，找到组织了！

hdgd501 · 发表于 2018-12-11 08:16:07

好好学习，天天向上！

ryouss · 发表于 2018-12-12 11:14:31

1. 如附圖A,1#附檔無法解壓縮.

2. 附可解壓縮原文件之內容及注解(參考).

圖A

Dim swApp As Object
Dim Part As Object
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim FeatureData As Object
Dim Feature As Object
Dim Component As Object
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
'~~~ GetType ~~~
'~~~ swDocNONE = 0(Used to be TYPE_NONE)
'~~~ swDocPART = 1 (Used to be TYPE_PART)
'~~~ swDocASSEMBLY = 2 (Used to be TYPE_ASSEMBLY)
'~~~ swDocDRAWING = 3
If Part.GetType <> 2 Then End '判定不是組件就結束
'~~ 沒有選取事件就判定為"Nothing"
Set SelMgr = Part.SelectionManager
Set c1 = SelMgr.GetSelectedObjectsComponent(1) '
Set c2 = SelMgr.GetSelectedObjectsComponent(2)
If c1 Is Nothing Then '判定沒有選取事件就結束
MsgBox "Wrong select"
End
End If
'~~~ 循環特徵取得"參考平面" ~~~
Set cm1 = c1.GetModelDoc
Set FeatObj = cm1.FirstFeature
FeatObjname = FeatObj.GetTypeName
While FeatObjname <> "RefPlane"
Set FeatObj = FeatObj.GetNextFeature
FeatObjname = FeatObj.GetTypeName
Wend
Stop
c1xy = FeatObj.Name '取得首選零件"前基準面"
Set FeatObj = FeatObj.GetNextFeature
c1xz = FeatObj.Name '取得首選零件"上基準面"
Set FeatObj = FeatObj.GetNextFeature
c1yz = FeatObj.Name '取得首選零件"右基準面"
'======== 取得組件基準面 ========
If c2 Is Nothing Then
Set c2 = Part
Set cm2 = Part
Set FeatObj = cm2.FirstFeature
FeatObjname = FeatObj.GetTypeName
While FeatObjname <> "RefPlane"
Set FeatObj = FeatObj.GetNextFeature
FeatObjname = FeatObj.GetTypeName
Wend
c2xy = FeatObj.Name
Set FeatObj = FeatObj.GetNextFeature
c2xz = FeatObj.Name
Set FeatObj = FeatObj.GetNextFeature
c2yz = FeatObj.Name
Else
If c1.Name2 = c2.Name2 Then '判定兩個選取事件是否同一零件
MsgBox "Same Component"
End
End If
'======== 取得第二零件基準面 ========
Set cm2 = c2.GetModelDoc
Set FeatObj = cm2.FirstFeature
FeatObjname = FeatObj.GetTypeName
While FeatObjname <> "RefPlane"
Set FeatObj = FeatObj.GetNextFeature
FeatObjname = FeatObj.GetTypeName
Wend
c2xy = FeatObj.Name
Set FeatObj = FeatObj.GetNextFeature
c2xz = FeatObj.Name
Set FeatObj = FeatObj.GetNextFeature
c2yz = FeatObj.Name
End If
'~~~~~ 結合基準面 ~~~~~
Set p1xy = c1.FeatureByName(c1xy)
Set p1xz = c1.FeatureByName(c1xz)
Set p1yz = c1.FeatureByName(c1yz)
Set p2xy = c2.FeatureByName(c2xy)
Set p2xz = c2.FeatureByName(c2xz)
Set p2yz = c2.FeatureByName(c2yz)
p1xy.Select2 False, 0
p2xy.Select2 True, 0
Set M1 = Part.AddMate2(0, 0, False, 0, 0, 0, 1, 1, 0, 0, 0, longstatus)
p1xz.Select2 False, 0
p2xz.Select2 True, 0
Set M2 = Part.AddMate2(0, 0, False, 0, 0, 0, 1, 1, 0, 0, 0, longstatus)
p1yz.Select2 False, 0
p2yz.Select2 True, 0
Set M3 = Part.AddMate2(0, 0, False, 0, 0, 0, 1, 1, 0, 0, 0, longstatus)
'Part.ClearSelection2 True
Part.EditRebuild
End Sub

复制代码

wxf58888 · 发表于 2020-11-26 10:34:54

经典图书

学习一下``````

cwzjd123 · 发表于 4 天前

下载了无法解压缩，提示损坏

suetee · 发表于前天 13:50

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

		自动登录	找回密码
密码			立即注册

版大的自动结合宏（转来收藏的）

浏览过的版块

最佳新人

活跃会员

热心会员

宣传达人

灌水之王

突出贡献

版大的自动结合宏 （转来收藏的）

浏览过的版块

最佳新人

活跃会员

热心会员

宣传达人

灌水之王

突出贡献

版大的自动结合宏（转来收藏的）