将图号、零件名、版本分割，并按约定格式保存文件的宏程序

kavenlee72

& y' u2 r  A0 h) i) n'本程序自动将零件以“图号(国标号)_零件名_版本”的格式保存；
% _, J" |( [  Q
'注意：
! J' B$ B  _7 a'①零件名不能以数字开头和结尾；
'②零件名内不能有空格、全角的“·”；

  Dim swApp               As SldWorks.SldWorks
1 _" R& j3 Q  T) w0 F; ^    Dim swModel             As SldWorks.ModelDoc2
5 S- R: H, \6 e/ X+ g    Dim swPart              As SldWorks.PartDoc
3 e+ L6 k2 {% l2 f; m, f    Dim swConfigMgr         As SldWorks.ConfigurationManager
+ C! q* `3 u! B. D4 ~+ C    Dim swConfig            As SldWorks.Configuration
    Dim swCustPropMgr       As SldWorks.CustomPropertyManager
' |' @6 T) ^: ]$ u1 H' B' h1 X    Dim swConfPropMgr       As SldWorks.CustomPropertyManager
    Dim a                   As String
; B; r. L# G5 g  U    Dim i                   As Variant
    Dim j                   As Variant
5 v% ~$ o; l: w+ x/ A    Dim b                   As String
, y& U* }0 v, ~! s" M# A    Dim c                   As String
    Dim e                   As String
    Dim t                   As String
    Dim q                   As Long
+ A* q% @+ z# I; D; V% F- ]) J$ E1 `    Dim BB                  As String
    Dim OldPath             As String
    Dim FilePath            As String
    Dim OldName             As String
, g' l$ g3 A3 {  Q3 u    Dim FileName            As String
   
( j3 k! \# U' B/ _& n   
Sub main()
7 Z/ e6 J& p& v/ T  I    Set swApp = Application.SldWorks
2 f. \0 l  M4 F+ O" A   
: J1 U; H& [5 ^3 L" F    Set swModel = swApp.ActiveDoc
   
) a" C) |' l# V+ p( x    Set swPart = swModel
   
    Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")
   
0 J; `& G7 ~. y- o    Set swConfigMgr = swModel.ConfigurationManager
5 o0 ^& i- o, N; |5 Z. G   
    Set swConfig = swConfigMgr.ActiveConfiguration
! R( ?  x! x0 B# y. Y- _) @/ [   
% P$ U. X0 {+ v- V    Set swConfPropMgr = swConfig.CustomPropertyManager
+ Q8 P# c  r* J. D6 f' Q0 z   
    swApp.ActiveDoc.ActiveView.FrameState = 1
$ Q# [) {$ Q3 O- B   
  O2 f2 k& M5 j2 ^    OldPath = swModel.GetPathName   '获取文件路径
' x9 l/ a) }' d; i0 h0 g0 `8 W; z   
' L: R; t; g4 E    If OldPath = "" Then     '判断是否为新文件（即未保存过的文件）
        
! ^9 O/ Z% Y. X        swModel.Save          '如果是，则保存
        
# Q) M) L# @  T7 P5 D* ~1 @9 e        OldPath = swModel.GetPathName   '重新获取文件路径
   
- H, i. e2 [. @, n) Z    End If
   
'将路径和零件名(含国标号/图号)分割开来
8 e3 r* r. f& P: |" Z    q = InStrRev(OldPath, "\")
" \- W1 U. h6 p7 r  ~   
    OldName = Mid(OldPath, q + 1)
! h2 L" d2 q% |' F" N                        
4 F) k1 F, Y5 K! Z9 W0 v" d) p    FilePath = Mid(OldPath, 1, q)
           
7 Y7 H+ y1 H! ^3 t* {    t = Right(OldName, 7)
$ f, p0 n2 v: h2 z! n            
4 V3 w, e3 ?% r/ W' C8 i    If t = ".SLDPRT" Or t = ".sldprt" Or t = ".Sldprt" Or _
        t = ".SLDASM" Or t = ".sldasm" Or t = ".Sldasm" Then
4 L* P, w" N5 I- G' y               
        c = Left(OldName, Len(OldName) - 7)
: s1 t  r3 o( T) ~               
  End If
8 b. a" T. q$ s9 E7 A- e4 }9 T   
6 U0 N' V7 E  O6 P8 [( l) s& I' C'判断文件名是否含版本号,如果是，则分割版本号
    BB = Right(c, 3)
1 }1 N+ c3 z1 V    If Len(BB) >= 3 Then
   
        If Left(BB, 1) = "_" And (Asc(Mid(BB, 2, 1)) > 64 And Asc(Mid(BB, 2, 1)) < 91) And (Asc(Mid(BB, 3, 1)) >= 48 And Asc(Mid(BB, 3, 1)) <= 57) Then
" Z6 A* z, t! X* V: t4 u        
( _: ]6 q+ E+ h' v- w% D6 I9 G            BB = Right(c, 2): c = Left(c, Len(c) - 3)
      
) r6 f( |3 ], M: F# @" m        Else
2 `7 N3 |4 d1 K5 f2 L- u   
            BB = ""
% A& S8 W) _* s8 @) l            
        End If
; {' z* Y( g3 }1 j; D, j        
    End If
'下面是图号/国标号与零件名的分割
    If Left(c, 5) = "XXXWG" Then      '如果前面是XXXWG，则判断为外购件
        
        e = Left(c, 11)               '外购件的编号为XXXWG□.□□□□,所以选前面11位为外购件编号
+ f/ z. B' I0 a* D) U% `/ |            
/ q( q8 p3 t& m1 i& M* r0 G! x+ q3 m        q = 12
2 P5 P4 ]" `* R! }& `            
    ElseIf Left(c, 2) = "XX" Then     '如果零件名前两位是"XX"，则判断XX后面是否为图号
% u% \) R/ N4 \1 A9 t' K- o   
        If Mid(c, 6, 1) <> "." Then b = c: goto FileName    '如果从左边数起第6位不是"."，则判断为不带图号
            
! ?5 Y' P+ w' X8 \        If Len(c) <= 5 Then b = c: goto FileName            '如果从左边数起第6位是"."，则判断3到5位是不是数字（按XX的图号命名规则，
: R4 @# B7 K; `/ |4 W            
: o2 r2 m" J" G) y5 Z1 c        For i = 3 To 5                                     '3到5位是数字），如果不是，则不是图号
4 [$ a) e, }* Z! |        
+ v( m0 j, z; S; M. s$ f' q1 E3 T            a = Mid(c, i, 1)
        
            If (Asc(a) < 48 Or Asc(a) > 57) Then b = c: goto FileName
' V4 F: l( S0 ?5 I' M            
1 F  d! F2 {2 T& h$ g+ [7 Z/ r        Next i
3 q2 _/ ]3 N# L9 b4 g& Q: v3 q            
        i = 7
4 D; m) N6 I" u; c5 b            
        a = Mid(c, i, 1)
' b/ W* h! _1 _5 Y) [* F+ h            
        If (Asc(a) < 48 Or Asc(a) > 57) Then b = c: goto FileName
            
6 T/ ^! d- d0 ^) q0 m        For q = i To Len(c)                                     '如果3到5位是数字，
            
$ f5 L7 A% S" t4 S7 A" I3 J' g            a = Mid(c, q, 1)
            
            j = Mid(c, q + 1, 1)
  \- C/ F  L" g4 F; }- I& y) v            
            If a = "." And (Asc(j) > 64 And Asc(j) < 91) Then   '判断图号是否为修改版本(A-Z,
                                                                '其AscII码为65-90),如果是，
                e = Left(c, q + 1)                              '则将其后分割
' N- R: @9 l# d               
$ S# W8 P. s5 D' Z                q = q + 2
               
                Exit For
            
            ElseIf (a = "_" Or ((Asc(a) < 48 Or Asc(a) > 57) And (Asc(j) < 48 Or Asc(j) > 57))) Then
& p: i" n1 ?% h7 P. y                                                 '如果文件名中含有分割符“_”，
* |0 ?/ m4 k* M1 Q4 {. I                e = Left(c, q - 1)               '或者连续两个符号均不是数字，则分割
3 Y1 T7 `# [3 |               
  ~& y) x2 W  c3 O) ?  A- U2 L                Exit For
               
            End If
0 K6 c" G2 {, X: _7 d            
        Next q
               
, p# @) M3 x* s  c! Q    ElseIf Left(c, 2) = "GB" Or Left(c, 2) = "JB" Then            '如果零件名前两位是"GB"或者"JB"，则以下过程为截取国标号
5 H. E5 C0 S- N! c        
3 E4 L, X" \: G: [  d4 W& N# U, B3 e! O        q = InStr(4, c, "-")
" f2 B' Y9 l  a  u" q        
# M$ C( [3 p$ C( C/ P- ^  K        If (Mid(c, q + 1, 2) = "19" Or Mid(c, q + 1, 2) = "20") Then
        
" A$ i- T6 ?: _+ v- K5 q: e            e = Left(c, q + 4)
  |. @8 R) m7 W1 I9 P, s) @               
: q# V/ f$ |1 Y& z  y            q = q + 5
            
% ?8 L4 x% I) x7 t$ i  [% u* n' a7 q       Else
4 g5 c% y/ h8 i# B  [               
            e = Left(c, q + 2)
               
$ U, s; }7 _& p( X/ |) a            q = q + 3
               
% V: i" ~$ ]. t; E" W  ?# `        End If
, Z! Y7 v' B# l( S( @" w2 {            
' }- n* x: b4 V0 F/ K( c& M" Y    End If
                                                         
. e  o! y( b0 ?3 e5 O  J" b'截取零件名
* @& h5 q* v1 n% v- ]    If Left(c, 2) = "GB" Or Left(c, 2) = "JB" Or Left(c, 2) = "XX" Then
6 E8 q" \5 N1 R" `- {# z4 S   
. C- q# _5 E5 N- e4 e. `        If Mid(c, q, 1) = "_" Then                             '如果已经有分割符("_")，则
" z# l/ |4 A7 U2 Q1 C8 f/ K   
            b = Mid(c, q + 1)                                  '分割符后为零件名
! i% H4 f6 U* V   
4 J+ A* B3 j5 N* [( ?, d0 ^7 ^2 S        Else                                                   '否则
8 u$ e6 }8 K- S% b4 \4 e6 l; a/ f4 m   
$ L  h2 I- L' V% V$ I' P$ m            b = Mid(c, q)                                      '从当前位置分割
1 X: L& D- T' x2 N) B$ V   
" w4 _# d* f6 L/ i7 V& e        End If
1 ?% A' ?5 |" a8 k5 h0 \   
$ r, x- J) ]+ }) H* O2 r, L; Q    Else
   
        b = c       '如果图号或国标号为空，则零件名=文件名
   
$ v2 X( _) i% d. f    End If
; G0 G- C0 c. L9 F4 ^   
'将BT改为B／T, B/改为B／, 2位年份改为4位年份
# d( g8 x! R, `& |0 J    If e <> "" Then
   
3 W! L2 A+ C" |1 F  H        a = Mid(e, 2, 2)
- D" g- h2 D. w0 `            
$ j  u/ _+ a, C6 T, I4 h; j        If a = "BT" Then e = Replace(e, "BT", "B／T")       '将BT改为B／T
     
6 Z( g+ m3 x- X% v& s6 r        If a = "B/" Then e = Replace(e, "B/", "B／")        '将B/改为B／
        
        a = Mid(Right(e, 3), 1, 1)
  ]$ {* P8 m  O. n        
" x/ r( H- Z* |        If a = "-" Then e = Replace(e, "-", "-19")          '将2位年份改为4位年份
# T- M0 \$ X: P' v        
/ v& k6 z# I7 ~! L- H& z$ d5 {    End If
( w3 b4 i: O- C5 K: I1 Y3 a( [
$ ]5 |) g' G) {+ x, p! FFileName:
& Q  ]0 g4 s0 {: ^: X% @    If e = "" And BB = "" Then FileName = b + t
   
7 _2 l6 Y1 g! n$ K$ S+ i) A    If e = "" And BB <> "" Then FileName = b + "_" + BB + t
0 E# u4 q% |' X   
/ \* d6 \9 M# F6 q9 P    If e <> "" And BB = "" Then FileName = e + "_" + b + t
$ g  r3 c! R5 l   
6 I) j8 M, L, |( t" U6 }    If e <> "" And BB <> "" Then FileName = e + "_" + b + "_" + BB + t
1 d+ [9 J8 |, S; c% f' R& j    swModel.SaveAs (FilePath + FileName)
  K' d) S  h, E% I4 h* {7 P   
   End Sub

tzydsfy

我正在找的,谢谢楼主

tzydsfy

真是高手