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

ryouss

參考
1 H$ s; D" r/ D+ Z/ H3 @& k' P7 y8 D


  m1 O9 W# b: J  ^) I1 O5 t

( [2 ~$ |- |+ C; X( a) S  \- o

1. '~~~~~~~~~~~~~~~~ 2019/07/04 ~~~~~~~~~~~~~~~~
   - w* @- a8 h, P1 }
2. ' 操作:
   
3. '   1. 開 EXCEL文件.
   
4. '   2. 開 SW零件.
   / D( e* Q% d! O5 s
5. '   3. 執行 ReadSwDimensionInSldPrt().
   6 }; F' V+ T' b" t+ A: y& z% g
6. '   4. 在EXCEL修改尺寸.
   - `; O1 w2 q/ O( J
7. '
   
8. ' 功能:
   / H4 J' D. Y4 ~* X" S
9. '   1. 讀取SW零件的全部尺寸,寫到 Excel.
   
10. '   2. 在Excel變動尺寸后,修改SW的零件尺寸.
    ' P9 S; s: Y; o7 `8 G( r0 {" p
11. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
12. Function SetSwPart()
    * E! W# i2 `4 H$ \. u3 L# B
13.   Dim SwApp As Object
    
14.   Dim SelMgr As Object, boolStatus As Boolean
    
15.   Dim longstatus As Long, longwarnings As Long
    5 ]3 X( B0 y+ A! @% V
16.   Set SwApp = GetObject(, "sldworks.application")
    
17.   Set SetSwPart = SwApp.ActiveDoc
    
18. End Function
    ' F0 e* p  m- Q$ \
19. '****************************
    
20. Private Sub ReadSwDimensionInSldPrt()
    
21.   '讀取SW的全部尺寸
    
22.   Dim oDic
    : Q& p! _; r) Y- _: X
23.   Set oDic = CreateObject("Scripting.Dictionary")
    $ ~: B+ i0 c5 r. m& p
24. '*** Get active sheet in Excel
    
25.   Set xl = GetObject(, "Excel.Application")
    0 G& k3 ?  j! `9 j4 ^
26.   Set xls = xl.ActiveSheet
    5 h; P* p1 J" ?$ t7 l
27. With xls
    
28.     Dim swFeat As Object, swSubFeat As Object
    
29.     Dim swDispDim As Object, SwDim As Object
    
30.     Dim swAnn As Object
    " c; t+ D# Y! o2 m# M, R
31.     Dim bRet As Boolean
    
32.     Dim Str
    6 s& Q9 S2 V+ D
33.     Set SwApp = CreateObject("SldWorks.Application")
    - P6 z$ A, g% A, G' c0 h
34.     Set SwPart = SetSwPart
    4 m5 k/ ~1 X# R( d4 l- Z
35.     Set swFeat = SwPart.FirstFeature
    
36.     kk = 1
    
37.     Do While Not swFeat Is Nothing
    * y- n# Z; ]' k& K% |- F, L
38.         Debug.Print "  " + swFeat.Name
    
39.         Set swSubFeat = swFeat.GetFirstSubFeature
    0 `6 Y- r1 X  z7 H: H" Q
40.         Set swDispDim = swFeat.GetFirstDisplayDimension
    
41.         Do While Not swDispDim Is Nothing
    4 S( W) e+ I- s! H% y5 G
42.             Set swAnn = swDispDim.GetAnnotation
    
43.             Set SwDim = swDispDim.GetDimension
    
44.             'Debug.Print "    [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
    * o5 C/ A2 z9 U$ k' ^- V! Z
45.             Debug.Print SwDim.FullName, SwDim.GetSystemValue2("")
    
46.             Str = SwDim.FullName
    8 s$ o( o* G; {' H# ]$ J
47.             oArr = Split(Str, "@")
    
48.             Str = oArr(0) & "@" & oArr(1)
    ( N; ]1 a7 Y* e0 t9 R
49.             oDic(Str) = SwDim.GetSystemValue2("")
    
50.             Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
    . b( J: z7 r# {2 Z& m) c( p* m. ]
51.         kk = kk + 1
    # h% |, v! Y, V8 }8 V& h* j
52.         Loop
    
53.         Set swFeat = swFeat.GetNextFeature
    5 D6 N% _$ V3 k# Q  b5 B" m: H
54.     Loop
    4 q& k3 S. J, Z, h7 D, d
55.     Dim oArr1, oArr2
    , G$ q* n* C9 N0 W' _; a
56.     oArr1 = oDic.keys: oArr2 = oDic.Items
    # y9 y+ P- n8 ]) ]6 Q
57.     .cells(1, 1) = "Serial number": .cells(1, 2) = "Array staging": .cells(1, 3) = "Dimension name"
    % k3 E4 M9 O0 [+ Y; U1 A; v: H
58.     .cells(1, 4) = "Feature name": .cells(1, 5) = "Dimension value":
    6 v8 j# {$ s8 e/ m
59.    
    ) t4 O; w8 x6 h7 q% t, d, U$ F
60.     For kk = 2 To UBound(oArr1) + 2
    + w. s" N; J6 {8 M
61.         .cells(kk, 1) = kk - 2
    
62.         .cells(kk, 2) = "=" & """Arr(""" & " & " & .cells(kk, 1) & " & " & """)="""
    ) X* M# }% R$ P$ z. E
63.         .cells(kk, 3) = "'" & Chr(34) & oArr1(kk - 2) & Chr(34)
    - S9 {+ g6 m; o% }5 X" K
64.         .cells(kk, 4) = Split(oArr1(kk - 2), "@")(1)
    
65.         .cells(kk, 5) = oArr2(kk - 2)
    5 {4 i3 A7 o+ C% k- D6 E
66.     Next kk
    
67. nn = .range("C65536").End(3).Row 'End(3)==>End(xlUp)
    1 \  B4 W" ^3 m$ I* u
68. Stop '暫停修改Excel之尺寸後,再按RUN執行鍵
    2 w; j# x% w+ N/ H% U
69. Set Part = SwApp.ActiveDoc
    
70. '依據Excel變動值修改到sw零件
    % E, Y" M1 ?7 F
71. For mm = 2 To nn
    
72.     Size_name = Mid(.cells(mm, 3), 2, Len(.cells(mm, 3)) - 2)
    : [1 M+ f' d& C  N! C
73.     Part.Parameter(Size_name).SystemValue = .cells(mm, 5)
    
74. Next mm
    ) i. q5 s! _# E# h
75. End With
    
76. boolStatus = Part.EditRebuild3()
    
77. MsgBox "Part size modification ends" '零件尺寸修改結束
    
78. End Sub
    

复制代码

5 O; U* B) z; ^+ C
" ^& ^  v5 @$ \
  {6 h( F4 v  l0 C* s

零度freedom

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

ィ心兂鎅

大神，三维网也发了吗？

未来第一站

zmztx

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

ryouss

0 N7 [$ N2 D1 N+ B3 G
Private Sub ReadSwDimensionInSldPrt()

1. 執行如上編程,鼠標須放在如上之下.再按"RUN"執行鍵.
2. 在SW2012,2017測試正常.

9 w7 d% ~; }  @0 i& J& `

ryouss

zmztx 发表于 2019-7-5 09:57
能给出注释吗？
, U8 m! j* |2 H7 j* q3 e: P' a怎么看上去运行不起来，或者不是全部代码？

" n3 j8 P2 _, R1 C# p  M3 G1 M/ NSW2017測試OK(有圖可證)
3 o& P0 o  l4 ^

$ I9 w7 d% y$ W$ u
6 q  k4 e8 e7 k# X6 Z4 k9 I9 y

zmztx

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

谢谢，我再仔细琢磨
0 B8 i+ P. ]8 f) E1 b, v/ {最上面的function似乎有点不对

ryouss

zmztx 发表于 2019-7-5 16:15
2 c  H6 U3 v* J9 Z谢谢，我再仔细琢磨
# F6 W+ W4 |$ V6 h) [4 ?# q最上面的function似乎有点不对

$ P# T; c3 y' K# p' d  _什麼版本測試的,顯示什麼錯誤提示?

远祥

这是神马啊？