有没有检测螺纹孔和沉头孔的宏

lengqiao · 发表于 2023-9-5 13:29:02

经典图书

有没有检测螺纹孔和沉头孔的宏，孔检查

xieguiming1982 · 发表于 2023-9-13 12:25:08

有没有检测螺纹孔和沉头孔的宏，孔检查
不知道是不是这意思

3869 · 发表于 2023-9-6 08:04:02

经典图书

顶一下，坐等高手！

沉默的人 · 发表于 2023-9-6 11:18:40

顶一下，坐等高手！

xiaohai2 · 发表于 2023-9-8 17:05:04

经典案例图书

很不错，找到组织了！

懒懒的高贵 · 发表于 2023-9-11 17:24:18

很不错，找到组织了！

xieguiming1982 · 发表于 2023-9-13 12:20:12

经典案例图书

Option Explicit
Dim swApp As Object
Dim swModelDoc, myModelDoc As ModelDoc2
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim cyDict As Object

Sub main()
Set cyDict = CreateObject("Scripting.Dictionary")

cyDict.Add "M1.6", 110    'R+G
cyDict.Add "M2", 11       'G+B
cyDict.Add "M2.5", 101    'R+B
cyDict.Add "M3", 100       'R
cyDict.Add "M4", 10       'G
cyDict.Add "M5", 1       'B
cyDict.Add "M6", 110       'R+G
cyDict.Add "M8", 11       'G+B
cyDict.Add "M10", 101    'R+B
cyDict.Add "M12", 100    'R
cyDict.Add "M14", 10       'G
cyDict.Add "M16", 1       'B
cyDict.Add "M20", 110    'R+G
cyDict.Add "M24", 11       'G+B
cyDict.Add "M30", 101    'R+B

Set swApp = Application.SldWorks
Set swModelDoc = swApp.ActiveDoc
If swModelDoc Is Nothing Then
ElseIf swModelDoc.GetType = swDocASSEMBLY Then
ElseIf swModelDoc.GetType = swDocPART Then
Set myModelDoc = swModelDoc
colorModelDoc myModelDoc
swModelDoc.ForceRebuild3 False
End If
End Sub

Sub colorModelDoc(myModelDoc As SldWorks.ModelDoc2)

Dim swPartDoc As PartDoc
Dim swFeature As Feature
Set swPartDoc = myModelDoc
Set swFeature = swPartDoc.FirstFeature
Dim swSelMgr As SelectionMgr
Dim strHoleSize As String
While Not swFeature Is Nothing
If swFeature.IsSuppressed = False Then
If swFeature.GetTypeName2 = "HoleWzd" Then
Dim swHolewzddata As WizardHoleFeatureData2
Set swHolewzddata = swFeature.GetDefinition
If cyDict.exists(swHolewzddata.FastenerSize) Then
Dim vMatPrps As Variant
vMatPrps = swFeature.GetMaterialPropertyValues2(swThisConfiguration, "")
vMatPrps(0) = cyDict.Item(swHolewzddata.FastenerSize) * 0.01 Mod 10
vMatPrps(1) = cyDict.Item(swHolewzddata.FastenerSize) * 0.1 Mod 10
vMatPrps(2) = cyDict.Item(swHolewzddata.FastenerSize) Mod 10
vMatPrps(3) = 1
vMatPrps(4) = 1
vMatPrps(5) = 1
vMatPrps(6) = 1
vMatPrps(7) = 0
vMatPrps(8) = 1
swFeature.SetMaterialPropertyValues2 vMatPrps, swThisConfiguration, ""
End If
End If
End If
Set swFeature = swFeature.GetNextFeature
Wend
End Sub

xieguiming1982 · 发表于 2023-9-13 12:22:12

Option Explicit
Dim swApp As Object
Dim swModelDoc, myModelDoc As ModelDoc2
Dim boolstatus As Boolean
Dim longstatus As Long, longwarnings As Long
Dim cyDict As Object
Sub main()
Set cyDict = CreateObject("Scripting.Dictionary")
cyDict.Add "M1.6", 110 'R+G
cyDict.Add "M2", 11 'G+B
cyDict.Add "M2.5", 101 'R+B
cyDict.Add "M3", 100 'R
cyDict.Add "M4", 10 'G
cyDict.Add "M5", 1 'B
cyDict.Add "M6", 110 'R+G
cyDict.Add "M8", 11 'G+B
cyDict.Add "M10", 101 'R+B
cyDict.Add "M12", 100 'R
cyDict.Add "M14", 10 'G
cyDict.Add "M16", 1 'B
cyDict.Add "M20", 110 'R+G
cyDict.Add "M24", 11 'G+B
cyDict.Add "M30", 101 'R+B
Set swApp = Application.SldWorks
Set swModelDoc = swApp.ActiveDoc
If swModelDoc Is Nothing Then
ElseIf swModelDoc.GetType = swDocASSEMBLY Then
ElseIf swModelDoc.GetType = swDocPART Then
Set myModelDoc = swModelDoc
colorModelDoc myModelDoc
swModelDoc.ForceRebuild3 False
End If
End Sub
Sub colorModelDoc(myModelDoc As SldWorks.ModelDoc2)
Dim swPartDoc As PartDoc
Dim swFeature As Feature
Set swPartDoc = myModelDoc
Set swFeature = swPartDoc.FirstFeature
Dim swSelMgr As SelectionMgr
Dim strHoleSize As String
While Not swFeature Is Nothing
If swFeature.IsSuppressed = False Then
If swFeature.GetTypeName2 = "HoleWzd" Then
Dim swHolewzddata As WizardHoleFeatureData2
Set swHolewzddata = swFeature.GetDefinition
If cyDict.exists(swHolewzddata.FastenerSize) Then
Dim vMatPrps As Variant
vMatPrps = swFeature.GetMaterialPropertyValues2(swThisConfiguration, "")
vMatPrps(0) = cyDict.Item(swHolewzddata.FastenerSize) * 0.01 Mod 10
vMatPrps(1) = cyDict.Item(swHolewzddata.FastenerSize) * 0.1 Mod 10
vMatPrps(2) = cyDict.Item(swHolewzddata.FastenerSize) Mod 10
vMatPrps(3) = 1
vMatPrps(4) = 1
vMatPrps(5) = 1
vMatPrps(6) = 1
vMatPrps(7) = 0
vMatPrps(8) = 1
swFeature.SetMaterialPropertyValues2 vMatPrps, swThisConfiguration, ""
End If
End If
End If
Set swFeature = swFeature.GetNextFeature
Wend
End Sub

复制代码

沉默的人 · 发表于 2023-9-13 13:37:07

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

lengqiao · 发表于 2023-9-13 17:25:35

经典图书

xieguiming1982 发表于 2023-9-13 12:22

首先感谢坛友回复，感谢！

机械工程师在打孔的时候，经常把孔打错，比如，下面板子上是M5牙孔，上面板子上是m5沉头孔，结果会把两个孔搞错掉，如一个是M5,一个是M6,,我想可以自动检查这俩个孔是不是匹配的

lengqiao · 发表于 2023-9-13 17:29:07

xieguiming1982 发表于 2023-9-13 12:25
有没有检测螺纹孔和沉头孔的宏，孔检查
不知道是不是这意思

首先感谢您的回复

比如上面板子上是M5沉头，下面一块板是M5牙孔，这两块个孔会错，不匹配，想自动检查这两个孔是不是匹配的

changfeng1229 · 发表于 2023-9-16 10:36:18

lengqiao 发表于 2023-9-13 17:29
首先感谢您的回复

比如上面板子上是M5沉头，下面一块板是M5牙孔，这两块个孔会错，不匹配，想自动检查 ...

如果用楼主这个宏，也不是不可以。如果两个零件孔位的颜色一致，证明尺寸是一样大小的了。换个角度看一下。

dragon045 · 发表于 2023-9-17 19:41:34

感谢楼主分享，很不错！

lengqiao · 发表于 2023-9-19 10:14:25

changfeng1229 发表于 2023-9-16 10:36
如果用楼主这个宏，也不是不可以。如果两个零件孔位的颜色一致，证明尺寸是一样大小的了。换个角度看一下 ...

这个宏咋用的

点了没反应呢

dragon045 · 发表于 2023-9-19 19:00:58

加入QQ群
参与讨论和学习

或扫描二维码加入

xieguiming1982 发表于 2023-9-13 12:25
有没有检测螺纹孔和沉头孔的宏，孔检查
不知道是不是这意思

装配体能不能用？

hhh001 · 发表于 2023-9-20 08:32:21

经典案例图书

活到老学到老！

redondo81 · 发表于 2023-9-30 12:58:50

加入QQ群
参与讨论和学习

或扫描二维码加入

很不错，找到组织了！

yni621 · 发表于 2024-1-20 08:18:06

经典案例图书

xieguiming1982 发表于 2023-9-13 12:25
有没有检测螺纹孔和沉头孔的宏，孔检查
不知道是不是这意思

能不能改成对应牙孔对应底孔改颜色，意思是M6是φ5.2的孔就一个颜色，因为接收别人的实体图，孔特征是没有的。

1215956038 · 发表于 2024-3-6 20:10:08

感谢楼主分享，很不错！

风雨阳光 · 发表于 2024-3-9 17:40:27

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

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

有没有检测螺纹孔和沉头孔的宏

最佳新人

活跃会员

宣传达人

热心会员

灌水之王

突出贡献