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

ryouss

參考
0 H7 k% C, V; N! g4 l- D: H/ ~: K+ U
# }: ~  X8 q8 q2 |" R9 G( h/ {; L

) O1 I6 E1 Q4 g% t* L


. t" h" d1 {* \% z

1. '~~~~~~~~~~~~~~~~ 2019/07/04 ~~~~~~~~~~~~~~~~
   
2. ' 操作:
   
3. '   1. 開 EXCEL文件.
   
4. '   2. 開 SW零件.
   
5. '   3. 執行 ReadSwDimensionInSldPrt().
   
6. '   4. 在EXCEL修改尺寸.
   9 a, l; _! H: k
7. '
   
8. ' 功能:
   # y/ S. B: g0 D) w
9. '   1. 讀取SW零件的全部尺寸,寫到 Excel.
   
10. '   2. 在Excel變動尺寸后,修改SW的零件尺寸.
    
11. '~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    & }$ W. z5 ?- t. Z, Q9 K
12. Function SetSwPart()
    
13.   Dim SwApp As Object
    ( `# x" G9 K2 d* Q
14.   Dim SelMgr As Object, boolStatus As Boolean
    ' w1 `& h* @4 T6 S: w+ L
15.   Dim longstatus As Long, longwarnings As Long
    
16.   Set SwApp = GetObject(, "sldworks.application")
    $ v1 t; u$ v) c. l* }
17.   Set SetSwPart = SwApp.ActiveDoc
    
18. End Function
    
19. '****************************
    + ]0 o9 U1 Y* d6 c) I/ h5 e
20. Private Sub ReadSwDimensionInSldPrt()
    0 W  V0 H( [% S8 _& X
21.   '讀取SW的全部尺寸
    
22.   Dim oDic
    
23.   Set oDic = CreateObject("Scripting.Dictionary")
    1 k2 ^6 [( K4 S$ |
24. '*** Get active sheet in Excel
    1 z* q% W4 R; ~' {& u6 {
25.   Set xl = GetObject(, "Excel.Application")
    5 h. `6 J/ W1 `7 o' m: V
26.   Set xls = xl.ActiveSheet
    3 u) H% l4 c& }+ m: c9 Z* B
27. With xls
    " M' @: |0 I/ W, |% G- u1 x
28.     Dim swFeat As Object, swSubFeat As Object
    2 U5 V1 E! M) ^; s. v$ X0 S1 D6 k
29.     Dim swDispDim As Object, SwDim As Object
    
30.     Dim swAnn As Object
    - R$ u' W! i+ S4 U! c% ]; t0 T
31.     Dim bRet As Boolean
    
32.     Dim Str
    9 m- Q; v! _; W* i5 b; k# P7 n0 z
33.     Set SwApp = CreateObject("SldWorks.Application")
    
34.     Set SwPart = SetSwPart
    7 Y2 M4 \2 x8 G3 ?  M
35.     Set swFeat = SwPart.FirstFeature
    % C  B2 _( `) D! {& Q: C3 g
36.     kk = 1
    
37.     Do While Not swFeat Is Nothing
    
38.         Debug.Print "  " + swFeat.Name
      L: n8 H8 G$ D1 \$ J- C; e9 A& @
39.         Set swSubFeat = swFeat.GetFirstSubFeature
    4 c9 u8 ^. E- i% l: x- @
40.         Set swDispDim = swFeat.GetFirstDisplayDimension
    + m9 e' X- _! }" n- d& _3 u
41.         Do While Not swDispDim Is Nothing
    
42.             Set swAnn = swDispDim.GetAnnotation
    ( X. s6 h8 K. t
43.             Set SwDim = swDispDim.GetDimension
    
44.             'Debug.Print "    [" & SwDim.FullName & "] = " & SwDim.GetSystemValue2("")
    
45.             Debug.Print SwDim.FullName, SwDim.GetSystemValue2("")
    
46.             Str = SwDim.FullName
    / H; b" F; D5 j- _3 L2 D4 M
47.             oArr = Split(Str, "@")
      R! ^1 d9 T; ~1 M" g- _
48.             Str = oArr(0) & "@" & oArr(1)
    
49.             oDic(Str) = SwDim.GetSystemValue2("")
    % j$ W, s$ @0 \# L* q
50.             Set swDispDim = swFeat.GetNextDisplayDimension(swDispDim)
    + W. L; Z; d# e5 R& j& |
51.         kk = kk + 1
    5 L7 p& d/ p5 h# u
52.         Loop
    
53.         Set swFeat = swFeat.GetNextFeature
    
54.     Loop
    1 ^" @4 X2 t# Q
55.     Dim oArr1, oArr2
    % u) @; q6 k, c! m, ]6 a; L
56.     oArr1 = oDic.keys: oArr2 = oDic.Items
    8 Q9 j9 k6 Y. ~5 C( x8 Y
57.     .cells(1, 1) = "Serial number": .cells(1, 2) = "Array staging": .cells(1, 3) = "Dimension name"
    9 ~, \3 `" X$ P& Y4 ?
58.     .cells(1, 4) = "Feature name": .cells(1, 5) = "Dimension value":
    
59.    
    ' _/ G! L2 E" ^5 j8 b* N
60.     For kk = 2 To UBound(oArr1) + 2
    4 k; y9 B% z8 k3 \; Y
61.         .cells(kk, 1) = kk - 2
    . o3 `: j1 Y/ K. B$ M% m8 @8 h& f  L
62.         .cells(kk, 2) = "=" & """Arr(""" & " & " & .cells(kk, 1) & " & " & """)="""
    0 _( B+ |. `- Y7 ]0 k# d+ d/ h/ t
63.         .cells(kk, 3) = "'" & Chr(34) & oArr1(kk - 2) & Chr(34)
    
64.         .cells(kk, 4) = Split(oArr1(kk - 2), "@")(1)
    
65.         .cells(kk, 5) = oArr2(kk - 2)
    
66.     Next kk
    
67. nn = .range("C65536").End(3).Row 'End(3)==>End(xlUp)
    
68. Stop '暫停修改Excel之尺寸後,再按RUN執行鍵
    
69. Set Part = SwApp.ActiveDoc
    ' [) Q+ C0 P2 P) s
70. '依據Excel變動值修改到sw零件
    ! N1 p6 t  G4 U7 k, Q
71. For mm = 2 To nn
    
72.     Size_name = Mid(.cells(mm, 3), 2, Len(.cells(mm, 3)) - 2)
    : b4 O) W! z/ r
73.     Part.Parameter(Size_name).SystemValue = .cells(mm, 5)
    ) q" u' d; |1 g8 n. r$ w/ D
74. Next mm
    
75. End With
    1 u+ p; k: W, C+ N; t; G3 l
76. boolStatus = Part.EditRebuild3()
    
77. MsgBox "Part size modification ends" '零件尺寸修改結束
    " K; |4 B! U! {
78. End Sub
    

复制代码

' S0 r. c" I% B  P2 h

零度freedom

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

ィ心兂鎅

大神，三维网也发了吗？

未来第一站

zmztx

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

ryouss

) Z! v5 G: s; V; p# D6 M/ a
1 v# w, c4 j' u& W* [- XPrivate Sub ReadSwDimensionInSldPrt()
* m; c  v, x1 R) R: z$ @
& |: M- o% V( y5 J7 L1. 執行如上編程,鼠標須放在如上之下.再按"RUN"執行鍵.
2. 在SW2012,2017測試正常.
+ F+ |, C: v5 d
/ ^( M" R2 w6 ?& W9 d3 e
6 v! Y7 d& y8 v

ryouss

zmztx 发表于 2019-7-5 09:57
' P8 ]8 V( [1 k2 a2 m能给出注释吗？
怎么看上去运行不起来，或者不是全部代码？

SW2017測試OK(有圖可證)



' L0 s; C. w# T

zmztx

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

谢谢，我再仔细琢磨
最上面的function似乎有点不对

ryouss

zmztx 发表于 2019-7-5 16:15
谢谢，我再仔细琢磨
最上面的function似乎有点不对

3 w# Z8 X9 C: C+ ^( o) [什麼版本測試的,顯示什麼錯誤提示?
1 ~+ @* @: |9 N+ B! R9 Y$ G

远祥

这是神马啊？