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

ryouss

參考

( o1 ^  M$ b% y2 E' p8 [' V
. |* X" Q7 l* [" f2 H

2 Z% S2 o3 X! t, c! X# }

, T3 d) e1 B; {- H" t$ }) i

1. '~~~~~~~~~~~~~~~~ 2019/07/04 ~~~~~~~~~~~~~~~~
   5 Y) v% e" @0 x" d& G8 T/ i: O
2. ' 操作:
   0 r5 a% S: N  ]3 F- h$ U* ]
3. '   1. 開 EXCEL文件.
   
4. '   2. 開 SW零件.
   
5. '   3. 執行 ReadSwDimensionInSldPrt().
   
6. '   4. 在EXCEL修改尺寸.
   1 G& i- F" u' @  i6 k/ J( C6 Z
7. '
   
8. ' 功能:
   
9. '   1. 讀取SW零件的全部尺寸,寫到 Excel.
   7 ]( U9 V/ i% U! N6 T
10. '   2. 在Excel變動尺寸后,修改SW的零件尺寸.
    
11. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
12. Function SetSwPart()
    ( y$ |2 T& H; Z- j% [
13.   Dim SwApp As Object
    7 B4 L% S( \- J1 J7 @
14.   Dim SelMgr As Object, boolStatus As Boolean
    : R* K6 j: y7 o5 @& ]  s" Q
15.   Dim longstatus As Long, longwarnings As Long
    ! |, {# ~( J7 j' L. d7 }; [8 P- C
16.   Set SwApp = GetObject(, "sldworks.application")
    
17.   Set SetSwPart = SwApp.ActiveDoc
    4 K% h- v, b% l3 O1 |3 D
18. End Function
    
19. '****************************
    % S5 l5 \* m- s$ {
20. Private Sub ReadSwDimensionInSldPrt()
    
21.   '讀取SW的全部尺寸
    
22.   Dim oDic
    0 M5 t. M; Y$ A0 R7 Y8 Y: o
23.   Set oDic = CreateObject("Scripting.Dictionary")
    
24. '*** Get active sheet in Excel
    , J% r6 Y2 i3 d1 K$ t
25.   Set xl = GetObject(, "Excel.Application")
    
26.   Set xls = xl.ActiveSheet
    7 X4 z0 [) O8 J6 g$ q+ }: p7 Q1 s
27. With xls
    ! A8 s: z& K% W9 R3 }
28.     Dim swFeat As Object, swSubFeat As Object
    
29.     Dim swDispDim As Object, SwDim As Object
    
30.     Dim swAnn As Object
    
31.     Dim bRet As Boolean
    
32.     Dim Str
    - B2 d8 E( s% g6 O
33.     Set SwApp = CreateObject("SldWorks.Application")
    
34.     Set SwPart = SetSwPart
    7 |) c0 v, M- h/ ?
35.     Set swFeat = SwPart.FirstFeature
    
36.     kk = 1
    , x: n8 r" n; W
37.     Do While Not swFeat Is Nothing
      `# b; J, q% z0 s8 J& |
38.         Debug.Print "  " + swFeat.Name
    * J) Z0 @3 ~, j' k
39.         Set swSubFeat = swFeat.GetFirstSubFeature
    
40.         Set swDispDim = swFeat.GetFirstDisplayDimension
    3 V4 [1 |1 w  p8 Z7 f3 m3 v
41.         Do While Not swDispDim Is Nothing
    " x& K# ~; z7 M# e( y
42.             Set swAnn = swDispDim.GetAnnotation
    : K% s$ x" \) o/ A4 j' t
43.             Set SwDim = swDispDim.GetDimension
    
44.             'Debug.Print "    [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
    
45.             Debug.Print SwDim.FullName, SwDim.GetSystemValue2("")
    9 u" X5 ?! w. k6 R5 o
46.             Str = SwDim.FullName
    
47.             oArr = Split(Str, "@")
    2 j7 e/ }: l6 W1 P) o$ ^
48.             Str = oArr(0) & "@" & oArr(1)
    " W: Y/ N  p; b, s6 `  I# B0 \8 v
49.             oDic(Str) = SwDim.GetSystemValue2("")
    
50.             Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
    
51.         kk = kk + 1
    
52.         Loop
    ! E# G: Q' y7 D* i/ G) K
53.         Set swFeat = swFeat.GetNextFeature
    
54.     Loop
    . U- j8 |* s0 B$ s- {& k5 F/ T
55.     Dim oArr1, oArr2
    
56.     oArr1 = oDic.keys: oArr2 = oDic.Items
    
57.     .cells(1, 1) = "Serial number": .cells(1, 2) = "Array staging": .cells(1, 3) = "Dimension name"
    : n  g) l, V. w
58.     .cells(1, 4) = "Feature name": .cells(1, 5) = "Dimension value":
    & R& ~/ ^) j/ @  `/ S; m$ a( }
59.    
    
60.     For kk = 2 To UBound(oArr1) + 2
    / f; c' `% W; Q( i4 }
61.         .cells(kk, 1) = kk - 2
    
62.         .cells(kk, 2) = "=" & """Arr(""" & " & " & .cells(kk, 1) & " & " & """)="""
    
63.         .cells(kk, 3) = "'" & Chr(34) & oArr1(kk - 2) & Chr(34)
    ' @  x$ [6 I8 n+ \
64.         .cells(kk, 4) = Split(oArr1(kk - 2), "@")(1)
      l. Q: l+ j% s9 @
65.         .cells(kk, 5) = oArr2(kk - 2)
    7 s. M9 s; v: g7 G& M% W8 x
66.     Next kk
    
67. nn = .range("C65536").End(3).Row 'End(3)==>End(xlUp)
    
68. Stop '暫停修改Excel之尺寸後,再按RUN執行鍵
    / H5 [4 |0 l' i$ B) B0 B
69. Set Part = SwApp.ActiveDoc
    
70. '依據Excel變動值修改到sw零件
    , o* P) l) n! Y! y" q; c' L3 ~
71. For mm = 2 To nn
    
72.     Size_name = Mid(.cells(mm, 3), 2, Len(.cells(mm, 3)) - 2)
    
73.     Part.Parameter(Size_name).SystemValue = .cells(mm, 5)
    3 N- s& Q* }! t( O
74. Next mm
    % Z" L; q: e8 A) g  ~2 j" ]
75. End With
    
76. boolStatus = Part.EditRebuild3()
    1 P+ p% O  P' n7 ?1 s$ Z! ]
77. MsgBox "Part size modification ends" '零件尺寸修改結束
    0 T) w7 z9 ]. z# u
78. End Sub
    

复制代码

$ P( X( G$ Q4 y& G

* H0 V  o3 L0 U- E- r0 H

) e* S& n$ H1 P- S
( ]# U( W. k; s- q& X! f( D

零度freedom

想法很好SW和表格挂钩，不过这个改尺寸的，和SW的设计表有点类似

ィ心兂鎅

大神，三维网也发了吗？

未来第一站

zmztx

能给出注释吗？
怎么看上去运行不起来，或者不是全部代码？

ryouss

0 r9 l/ M6 O1 ~
# p" n: k, n  }; ~. K2 wPrivate Sub ReadSwDimensionInSldPrt()
& A8 Q7 d8 c9 o- r2 X1 X2 L0 O9 {. q
1. 執行如上編程,鼠標須放在如上之下.再按"RUN"執行鍵.
# J+ W6 m$ X  }3 F8 Z2. 在SW2012,2017測試正常.


5 E) z. Y! Z/ O9 ^

ryouss

zmztx 发表于 2019-7-5 09:57
4 Z) ]3 Y# c8 x! g" Y7 q+ o能给出注释吗？
- }" `5 K9 S6 i2 C7 a" E怎么看上去运行不起来，或者不是全部代码？

; z' N2 O8 ~! t& RSW2017測試OK(有圖可證)



) e) @- |  `1 K2 c3 A* p

zmztx

ryouss 发表于 2019-7-5 11:11
SW2017測試OK(有圖可證)

谢谢，我再仔细琢磨
最上面的function似乎有点不对
9 ^, J% K! c( B2 H. [

ryouss

zmztx 发表于 2019-7-5 16:15
. @# M3 _& c3 o) @  y' u1 r谢谢，我再仔细琢磨
! \" v) T) t, }4 l9 ]1 D最上面的function似乎有点不对

什麼版本測試的,顯示什麼錯誤提示?

远祥

这是神马啊？