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

ryouss

參考

+ r3 ]7 w/ Y, Z* V; w+ C
# u  j; s. Q. N, F8 L/ W( \

6 ~* t; i* i" u& l( d6 G) Q1 A% A* v


$ g$ ^; ^  T* [# h

1. '~~~~~~~~~~~~~~~~ 2019/07/04 ~~~~~~~~~~~~~~~~
   
2. ' 操作:
   * r( d4 _: O! r& T: D
3. '   1. 開 EXCEL文件.
   
4. '   2. 開 SW零件.
   . @/ D! Y$ E% h% J' v" |; p
5. '   3. 執行 ReadSwDimensionInSldPrt().
   ( x- l) u! K) M1 {# E! ?2 o
6. '   4. 在EXCEL修改尺寸.
     P  b" h0 t' I% p) @) k* w& V6 i$ Z
7. '
   
8. ' 功能:
   
9. '   1. 讀取SW零件的全部尺寸,寫到 Excel.
   
10. '   2. 在Excel變動尺寸后,修改SW的零件尺寸.
    
11. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    
12. Function SetSwPart()
    , u) i7 Z; }1 l; ~
13.   Dim SwApp As Object
    % k8 A4 n3 }" s3 J4 ^- P
14.   Dim SelMgr As Object, boolStatus As Boolean
    
15.   Dim longstatus As Long, longwarnings As Long
    ' ~, y0 R0 ?3 Q2 }+ P8 Z
16.   Set SwApp = GetObject(, "sldworks.application")
    
17.   Set SetSwPart = SwApp.ActiveDoc
    . c2 x% [* @; @1 p7 U' ~
18. End Function
    9 g2 `  ]. H3 d  Z5 d
19. '****************************
    3 k3 Q/ T4 `, Y6 M& c  l0 K9 q3 d
20. Private Sub ReadSwDimensionInSldPrt()
    
21.   '讀取SW的全部尺寸
    
22.   Dim oDic
    - ]5 c7 k5 p2 i4 B5 u3 G% [
23.   Set oDic = CreateObject("Scripting.Dictionary")
    
24. '*** Get active sheet in Excel
    + u/ n& p' [  j: b, V- f
25.   Set xl = GetObject(, "Excel.Application")
    
26.   Set xls = xl.ActiveSheet
    
27. With xls
    . y  r6 {3 K6 G8 H
28.     Dim swFeat As Object, swSubFeat As Object
    9 ]6 U+ ~5 v1 m, f3 r" d
29.     Dim swDispDim As Object, SwDim As Object
    
30.     Dim swAnn As Object
    
31.     Dim bRet As Boolean
    2 h: \5 W* K  u+ g; _' b, R
32.     Dim Str
    8 p1 J/ E2 e/ M
33.     Set SwApp = CreateObject("SldWorks.Application")
    3 w: J9 L# t; W- M8 ~
34.     Set SwPart = SetSwPart
    / E2 P5 s- B$ X- E3 a9 p8 k
35.     Set swFeat = SwPart.FirstFeature
    
36.     kk = 1
    & y2 x4 a) E& `5 A3 ^
37.     Do While Not swFeat Is Nothing
    
38.         Debug.Print "  " + swFeat.Name
    6 z2 W0 }' X7 O( \/ M- Y
39.         Set swSubFeat = swFeat.GetFirstSubFeature
    8 b5 c( q) J- p
40.         Set swDispDim = swFeat.GetFirstDisplayDimension
    % \" e3 i* f/ g& n5 X) ?$ D
41.         Do While Not swDispDim Is Nothing
    
42.             Set swAnn = swDispDim.GetAnnotation
    0 L# ^0 \( o* X; _# }
43.             Set SwDim = swDispDim.GetDimension
    ) l% c2 ]! C  U% I& p# J- w
44.             'Debug.Print "    [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
    - ~. H6 r4 E4 ^; y7 {& Q
45.             Debug.Print SwDim.FullName, SwDim.GetSystemValue2("")
    
46.             Str = SwDim.FullName
    
47.             oArr = Split(Str, "@")
    
48.             Str = oArr(0) & "@" & oArr(1)
    ( D/ E6 i, F7 I
49.             oDic(Str) = SwDim.GetSystemValue2("")
    . ^; T  Z+ p7 w% j, h
50.             Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
    . `+ ^( P- w4 L4 E1 `3 a
51.         kk = kk + 1
    4 j0 N1 n+ B: `% y/ z
52.         Loop
    
53.         Set swFeat = swFeat.GetNextFeature
    
54.     Loop
    
55.     Dim oArr1, oArr2
    $ z+ h% l/ F2 R
56.     oArr1 = oDic.keys: oArr2 = oDic.Items
    * M; y4 d8 k; I5 ~$ Y0 @- j' Z
57.     .cells(1, 1) = "Serial number": .cells(1, 2) = "Array staging": .cells(1, 3) = "Dimension name"
    
58.     .cells(1, 4) = "Feature name": .cells(1, 5) = "Dimension value":
    - ?# f: b9 @7 E3 ]3 I
59.    
    
60.     For kk = 2 To UBound(oArr1) + 2
    
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)
    7 @# G- w* w5 T+ M/ h% Q
64.         .cells(kk, 4) = Split(oArr1(kk - 2), "@")(1)
    0 E8 p, D; h- }# T4 n
65.         .cells(kk, 5) = oArr2(kk - 2)
      e! W( _# ]2 ?5 n* U: p) E( m
66.     Next kk
    : P; @" S0 E9 M( v& W/ Q% _
67. nn = .range("C65536").End(3).Row 'End(3)==>End(xlUp)
    % D+ v  P! w9 z" Z: n2 z7 f6 }
68. Stop '暫停修改Excel之尺寸後,再按RUN執行鍵
    . ?3 A8 A: x  f* W: m% `2 i, h
69. Set Part = SwApp.ActiveDoc
    
70. '依據Excel變動值修改到sw零件
    
71. For mm = 2 To nn
    
72.     Size_name = Mid(.cells(mm, 3), 2, Len(.cells(mm, 3)) - 2)
    ! L. q, e- q; p2 C$ O) f4 n; h
73.     Part.Parameter(Size_name).SystemValue = .cells(mm, 5)
    
74. Next mm
    
75. End With
    - x; j0 H8 J3 M5 y( d
76. boolStatus = Part.EditRebuild3()
    5 ]% ^! h3 x3 }; @/ |
77. MsgBox "Part size modification ends" '零件尺寸修改結束
    5 v2 r' v9 E' }; Q7 E& f' u
78. End Sub
    . G% j# V3 I2 M5 E2 W

复制代码

零度freedom

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

ィ心兂鎅

大神，三维网也发了吗？

未来第一站

zmztx

能给出注释吗？
; k1 i% I( X& u" q怎么看上去运行不起来，或者不是全部代码？

ryouss

Private Sub ReadSwDimensionInSldPrt()

1. 執行如上編程,鼠標須放在如上之下.再按"RUN"執行鍵.
2. 在SW2012,2017測試正常.
% q1 g. i6 _% S1 w" M8 o1 Z& j* G
6 e' V( Z; a* k0 d

ryouss

zmztx 发表于 2019-7-5 09:57
: @) K; H# x, p7 `- [能给出注释吗？
怎么看上去运行不起来，或者不是全部代码？

SW2017測試OK(有圖可證)

. [' r2 E* h% S8 H

zmztx

ryouss 发表于 2019-7-5 11:11
7 m9 I5 _9 P! x+ E5 bSW2017測試OK(有圖可證)

5 P) a# }% u! ~: v; \6 F! A谢谢，我再仔细琢磨
最上面的function似乎有点不对

ryouss

zmztx 发表于 2019-7-5 16:15
谢谢，我再仔细琢磨
/ g+ V, M8 D5 ]0 |  t$ [最上面的function似乎有点不对

* G) A/ r$ ]6 F( r$ x% M4 K: o  o. R. u什麼版本測試的,顯示什麼錯誤提示?
) @$ V8 B  J2 B4 h

远祥

这是神马啊？