在EXCEL修改SW零件尺寸-宏的練習
參考'~~~~~~~~~~~~~~~~ 2019/07/04 ~~~~~~~~~~~~~~~~
' 操作:
' 1. 開 EXCEL文件.
' 2. 開 SW零件.
' 3. 執行 ReadSwDimensionInSldPrt().
' 4. 在EXCEL修改尺寸.
'
' 功能:
' 1. 讀取SW零件的全部尺寸,寫到 Excel.
' 2. 在Excel變動尺寸后,修改SW的零件尺寸.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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")
'*** Get active sheet in Excel
Set xl = GetObject(, "Excel.Application")
Set xls = xl.ActiveSheet
With xls
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
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)
oDic(Str) = SwDim.GetSystemValue2("")
Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
kk = kk + 1
Loop
Set swFeat = swFeat.GetNextFeature
Loop
Dim oArr1, oArr2
oArr1 = oDic.keys: oArr2 = oDic.Items
.cells(1, 1) = "Serial number": .cells(1, 2) = "Array staging": .cells(1, 3) = "Dimension name"
.cells(1, 4) = "Feature name": .cells(1, 5) = "Dimension value":
For kk = 2 To UBound(oArr1) + 2
.cells(kk, 1) = kk - 2
.cells(kk, 2) = "=" & """Arr(""" & " & " & .cells(kk, 1) & " & " & """)="""
.cells(kk, 3) = "'" & Chr(34) & oArr1(kk - 2) & Chr(34)
.cells(kk, 4) = Split(oArr1(kk - 2), "@")(1)
.cells(kk, 5) = oArr2(kk - 2)
Next kk
nn = .range("C65536").End(3).Row 'End(3)==>End(xlUp)
Stop '暫停修改Excel之尺寸後,再按RUN執行鍵
Set Part = SwApp.ActiveDoc
'依據Excel變動值修改到sw零件
For mm = 2 To nn
Size_name = Mid(.cells(mm, 3), 2, Len(.cells(mm, 3)) - 2)
Part.Parameter(Size_name).SystemValue = .cells(mm, 5)
Next mm
End With
boolStatus = Part.EditRebuild3()
MsgBox "Part size modification ends" '零件尺寸修改結束
End Sub
想法很好SW和表格挂钩，不过这个改尺寸的，和SW的设计表有点类似 大神，三维网也发了吗？ :victory: 能给出注释吗？
怎么看上去运行不起来，或者不是全部代码？ 本帖最后由 ryouss 于 2019-7-5 10:35 编辑
Private Sub ReadSwDimensionInSldPrt()
1. 執行如上編程,鼠標須放在如上之下.再按"RUN"執行鍵.
2. 在SW2012,2017測試正常.
zmztx 发表于 2019-7-5 09:57
能给出注释吗？
怎么看上去运行不起来，或者不是全部代码？
SW2017測試OK(有圖可證)
ryouss 发表于 2019-7-5 11:11
SW2017測試OK(有圖可證)
谢谢，我再仔细琢磨
最上面的function似乎有点不对
zmztx 发表于 2019-7-5 16:15
谢谢，我再仔细琢磨
最上面的function似乎有点不对
什麼版本測試的,顯示什麼錯誤提示?
这是神马啊？
页:
[1]
2