ryouss 发表于 2019-7-8 09:34:36

在EXCEL修改SW零件尺寸-宏的練習

參考




'~~~~~~~~~~~~~~~~~~ 2019/07/06 V19070601 ~~~
' 操作:
'   1. 開 EXCEL文件.
'   2. 開 SW零件.
'   3. 執行 ReadSwDimensionInSldPrt().
'   4. 在EXCEL修改尺寸.
'
' 功能:
'   1. 讀取SW零件的全部尺寸,寫到 Excel.
'   2. 在Excel變動尺寸后,修改SW的零件尺寸.
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

Dim SwApp As Object
Dim boolStatus As Boolean
Dim swFeat As Object ', swSubFeat As Object
Dim swDispDim As Object, SwDim As Object
Dim Str
Dim oDic
Dim oArr1, oArr2

Private Sub ReadSwDimensionInSldPrt()
'讀取SW的全部尺寸
    Set SwApp = Application.SldWorks
    Set Part = SwApp.ActiveDoc
    Set oDic = CreateObject("Scripting.Dictionary")
'*** Get active sheet in Excel
    Set xl = GetObject(, "Excel.Application")
With xl.ActiveSheet
    Set swFeat = Part.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
            Str = SwDim.FullName '特徵樹名稱
            oArr = Split(Str, "@")
            Str = oArr(0) & "@" & oArr(1)
            oDic(Str) = SwDim.GetSystemValue2("")
            Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
            Debug.Print Str, oDic(Str) ', 符號相當於按Tab鍵
            kk = kk + 1
      Loop
      Set swFeat = swFeat.GetNextFeature
    Loop
    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) '(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










ryouss 发表于 2019-7-9 10:02:56

宏在SW的背景執行,也可以直接編寫在EXCEL執行!


James924 发表于 2019-7-9 16:23:47

这个本质是尺寸的超链接吗?

ryouss 发表于 2019-7-9 16:54:15

整個重點就是應用宏,讀取SW零件的全部尺寸,寫到 Excel.

tianma 发表于 2019-7-15 23:00:01

挺好,谢谢分享

dubailiu 发表于 2019-9-11 14:30:17

感谢分享!

jianghai 发表于 2020-4-17 19:48:15

能不能读取一个文件夹下所有零件的尺寸

peng188 发表于 2020-4-29 16:32:48

如何根据结构树标记的尺寸进行读取?
页: [1]
查看完整版本: 在EXCEL修改SW零件尺寸-宏的練習