尺寸驱动模型，写个通用的VBA代码，哪位大神能指导下？

ss404770848 · 发表于 2016-4-8 14:05:29

做个通用的VBA代码，要实现以下功能：打开已有的一个部件或零件，通过VBA提取部件或零件中所有的特征与草图所包含的尺寸名称与尺寸数值大小，导入到excel，再在excel中修改相应的尺寸数值，来驱动模型使之更新。
自己查的资料附上，只能读出零件的尺寸名称及数值，并写入excel。
Function SetSwPart()
  Dim SwApp As Object
  Dim SelMgr As Object, boolStatus As Boolean
  Dim longstatus As Long, longwarnings As Long

  Set SwApp = GetObject(, "sldworks.application")

  Set SetSwPart = SwApp.ActiveDoc

End Function
''****************************
Private Sub ReadSwDimensionInSldPrt()
  ''读SW的变量数据
  Dim oDic
  Set oDic = CreateObject("Scripting.Dictionary")


  nn = Range("A65536").End(3).Row
  Set Rng = Range("A1:Z" & nn)

Dim swFeat As Object, swSubFeat As Object
Dim swDispDim As Object, SwDim As Object
Dim swAnn As Object
Dim bRet As Boolean
Dim Str

Set SwApp = CreateObject("SldWorks.Application")
Set SwPart = SetSwPart
Set swFeat = SwPart.FirstFeature

kk = 1
Do While Not swFeat Is Nothing
      Debug.Print "  " + swFeat.Name
      Set swSubFeat = swFeat.GetFirstSubFeature
      Do While Not swSubFeat Is Nothing
         Debug.Print "    " + swSubFeat.Name

         Set swDispDim = swSubFeat.GetFirstDisplayDimension
         Do While Not swDispDim Is Nothing
            Set swAnn = swDispDim.GetAnnotation
            Set SwDim = swDispDim.GetDimension
            Debug.Print "       [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
            'Debug.Print swDim.FullName, swDim.GetSystemValue2("")
            Set swDispDim = swSubFeat.GetNextDisplayDimension(swDispDim)
         Loop
         Set swSubFeat = swSubFeat.GetNextSubFeature
      Loop

      Set swDispDim = swFeat.GetFirstDisplayDimension
      Do While Not swDispDim Is Nothing
         Set swAnn = swDispDim.GetAnnotation
         Set SwDim = swDispDim.GetDimension

         Debug.Print " [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
         Debug.Print SwDim.FullName, SwDim.GetSystemValue2("")
         Str = SwDim.FullName
         oArr = Split(Str, "@")
         Str = oArr(0) & "@" & oArr(1)
         '
         Cells(kk, 5) = SwDim.GetSystemValue2("")
         Cells(kk, 4) = oArr(1)
         Debug.Print SwDim.GetSystemValue2("")
         oDic(Str) = SwDim.GetSystemValue2("")

         Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
         kk = kk + 1
      Loop
      Set swFeat = swFeat.GetNextFeature
Loop
Dim oArr1, oArr2, cc
cc = 6
oArr1 = oDic.keys: oArr2 = oDic.items
For kk = 1 To UBound(oArr1) + 1
      Cells(kk, 1 + cc) = kk - 1
      Cells(kk, 2 + cc) = "=" & """Arr(""" & " & " & Cells(kk, 1 + cc).Address(0, 0) & " & " & """)="""
      Cells(kk, 3 + cc) = "'" & Chr(34) & oArr1(kk - 1) & Chr(34)
      Cells(kk, 4 + cc) = Split(oArr1(kk - 1), "@")(1)
      Cells(kk, 5 + cc) = oArr2(kk - 1)

Next kk
End Sub

ss404770848 · 发表于 2016-4-12 09:36:42

零件级的已解决，只差部件级的。

ss404770848 · 发表于 2016-4-15 16:06:01

高手来指导下吧

lcj2018 · 发表于 2018-6-12 19:59:17

支持一下，我也想学习学习！

冻结best · 发表于 2019-5-16 15:20:06

经典案例图书

求分享解决方案及代码

zjx839392 · 发表于 2019-5-16 21:41:16

谢谢分享

冻结best · 发表于 2019-5-17 17:27:45

经典案例图书

读取、写入SW变量数据部分代码可否分享一下

fuchong2009 · 发表于 2019-6-25 09:57:28

EXCEL数据赋值给SolidWorks特征尺寸变量参数：

'Values for calcualtions are in meters

Part.Parameter("球罐内直径@草图1").SystemValue = Range("B2").Value / 1000

Part.Parameter("球壳壁厚@草图1").SystemValue = Range("B3").Value / 1000

Part.Parameter("支柱外径@草图3").SystemValue = Range("B4").Value / 1000

Part.Parameter("托板厚度@拉伸-薄壁5").SystemValue = Range("B7").Value / 1000

Part.Parameter("透气孔@草图12").SystemValue = Range("B9").Value / 1000

Part.Parameter("透气孔孔距@草图12").SystemValue = Range("B10").Value / 1000
Part.EditRebuild
Part.ViewZoomtofit2
MsgBox "三维造型结束", vbOKOnly, "提示"
End Sub

332508689 · 发表于 2019-6-29 12:43:21

楼主，求指导，可否发送一份。

332508689 · 发表于 2019-6-29 12:54:47

楼主，这个怎么用？

ryouss · 发表于 2019-7-1 17:51:58

參考

'讀取SW零件的全部尺寸，寫到Excel。
'在Excel變動尺寸後，修改SW的零件尺寸。
函數SetSwPart（）
Dim SwApp作為對象
Dim SelMgr作為對象，boolStatus As Boolean
Dim longstatus As Long，longwarnings As Long
Set SwApp = GetObject（，“sldworks.application”）
Set SetSwPart = SwApp.ActiveDoc
End Function
'' **** ************************
Private Sub ReadSwDimensionInSldPrt（）
'讀取SW的全部尺寸
Dim oDic
Set oDic = CreateObject（“Scripting.Dictionary”）
' ***獲取Excel中的活動工作表
設置xl = GetObject（，“Excel.Application”）
設置xls = xl.ActiveSheet
使用
xls'nn = .range（“A65536”）。End（3）.Row'End（3） ==>
'設置Rng = .range（“A1：Z”＆nn）
Dim swFeat As Object，swSubFeat As Object
Dim swDispDim As Object，SwDim As Object
Dim swAnn As Object
Dim bRet As Boolean
Dim Str
Set SwApp = CreateObject（“SldWorks.Application” “）
設置SwPart = SetSwPart
設置swFeat = SwPart.FirstFeature
kk = 1
做什麼不是swFeat什麼都不
Debug.Print”“+ swFeat.Name
設置swSubFeat = swFeat.GetFirstSubFeature
做什麼不swSubFeat什麼都不
Debug.Print”“+ swSubFeat。名稱
設置swDispDim = swSubFeat。GetFirstDisplayDimension
執行時不是swDispDim什麼都不是
設置swAnn = swDispDim.GetAnnotation
設置SwDim = swDispDim.GetDimension
Debug.Print“[”＆SwDim.FullName＆“] =”＆SwDim.GetSystemValue2（“”）
'Debug.Print swDim.FullName，swDim.GetSystemValue2（“”）
設置swDispDim = swSubFeat.GetNextDisplayDimension（swDispDim）
循環
集swSubFeat = swSubFeat.GetNextSubFeature
循環
集swDispDim = swFeat.GetFirstDisplayDimension
執行時沒有swDispDim沒有
設置swAnn = swDispDim.GetAnnotation
設置SwDim = swDispDim.GetDimension
Debug.Print“[”＆SwDim.FullName＆“] =”＆SwDim.GetSystemValue2（“”）
Debug.Print SwDim.FullName，SwDim.GetSystemValue2（“”）
Str = SwDim.FullName
oArr = Split（Str，“@ “）
Str = oArr（0）＆”@“＆oArr（1）
.cells（kk，5）= SwDim.GetSystemValue2（”“）。
cells（kk，4）= oArr（1）
Debug.Print SwDim.GetSystemValue2 （“”）
oDic（Str）= SwDim.GetSystemValue2（“”）
設置swDispDim = swFeat.GetNextDisplayDimension（swDispDim）
kk = kk + 1
循環
設置swFeat = swFeat。GetNextFeature
Loop
Dim oArr1，oArr2，cc
cc = 6
oArr1 = oDic.keys：oArr2 = oDic.Items
for kk = 1 To UBound（oArr1）+ 1
.cells（kk，1 + cc）= kk - 1
.cells（kk，2 + cc）=“=”＆“ “”Arr（“”“＆”＆“＆.cells（kk，1 + cc）。Address（0,0）＆”＆“＆”“”）=“”“.
cells（kk，3 + cc） =“'”＆Chr（34）＆oArr1（kk - 1）＆Chr（34）
.cells（kk，4 + cc）=分裂（oArr1（kk - 1），“@”）（1）
.cells（ kk，5 + cc）= oArr2（kk - 1）
下一個kk
nn = .range（“I65536”）。End（3）.Row'End（3）==> End（xlUp）Stop'Chen
停修改Excel之尺寸後，再按RUN執行鍵
Set Part = SwApp.ActiveDoc
'依據Excel變動值修改到sw零件
對於mm = 1到nn
Size_name = Mid（.cells（mm，9），2，Len（.cells（mm，9）） - 2）
Part.Parameter（Size_name）.SystemValue = .cells（mm，11）
下一個mm
結束用
boolStatus = Part.EditRebuild3（）
MsgBox“零件尺寸修改結束”
End Sub

复制代码

ryouss · 发表于 2019-7-2 10:46:09

附swp文件

Macro0701.rar (11.8 KB, 下载次数: 66)

讀取SW零件的全部尺寸，寫到Excel。
在Excel變動尺寸後，修改SW的零件尺寸。

332508689 · 发表于 2019-7-12 11:11:43

ryouss 发表于 2019-7-2 10:46
附swp文件

讀取SW零件的全部尺寸，寫到Excel。

您好，宏文件用solidworks打不开，如果是装配体怎么弄呀，帮帮忙

332508689 · 发表于 2019-7-12 11:16:49

楼主，这个怎么用？

ryouss · 发表于 2019-7-13 11:37:10

加入QQ群
参与讨论和学习

或扫描二维码加入

332508689 发表于 2019-7-12 11:16
楼主，这个怎么用？

操作：
1.開EXCEL文件。
2.開SW零件。
3.執行ReadSwDimensionInSldPrt（）。
4.在EXCEL修改尺寸。

功能：
1.讀取SW零件的全部尺寸，寫到Excel。
2.在Excel變動尺寸後，修改SW的零件尺寸。

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

尺寸驱动模型，写个通用的VBA代码，哪位大神能指导下？

最佳新人

活跃会员

热心会员

宣传达人

灌水之王

突出贡献