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

kavenlee72 · 发表于 2016-5-5 22:20:49

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。

您需要登录才可以下载或查看，没有帐号？注册

x

本帖最后由 kavenlee72 于 2016-5-5 22:30 编辑

'本程序自动将零件以“图号(国标号)_零件名_版本”的格式保存；

'注意：
'①零件名不能以数字开头和结尾；
'②零件名内不能有空格、全角的“·”；

  Dim swApp             As SldWorks.SldWorks
Dim swModel          As SldWorks.ModelDoc2
Dim swPart             As SldWorks.PartDoc
Dim swConfigMgr       As SldWorks.ConfigurationManager
Dim swConfig          As SldWorks.Configuration
Dim swCustPropMgr    As SldWorks.CustomPropertyManager
Dim swConfPropMgr    As SldWorks.CustomPropertyManager
Dim a                As String
Dim i                As Variant
Dim j                As Variant
Dim b                As String
Dim c                As String
Dim e                As String
Dim t                As String
Dim q                As Long
Dim BB                As String
Dim OldPath          As String
Dim FilePath          As String
Dim OldName          As String
Dim FileName          As String

Sub main()
Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

Set swPart = swModel

Set swCustPropMgr = swModel.Extension.CustomPropertyManager("")

Set swConfigMgr = swModel.ConfigurationManager

Set swConfig = swConfigMgr.ActiveConfiguration

Set swConfPropMgr = swConfig.CustomPropertyManager

swApp.ActiveDoc.ActiveView.FrameState = 1

OldPath = swModel.GetPathName '获取文件路径

If OldPath = "" Then    '判断是否为新文件（即未保存过的文件）

      swModel.Save       '如果是，则保存

      OldPath = swModel.GetPathName '重新获取文件路径

End If

'将路径和零件名(含国标号/图号)分割开来
q = InStrRev(OldPath, "\")

OldName = Mid(OldPath, q + 1)

FilePath = Mid(OldPath, 1, q)

t = Right(OldName, 7)

If t = ".SLDPRT" Or t = ".sldprt" Or t = ".Sldprt" Or _
      t = ".SLDASM" Or t = ".sldasm" Or t = ".Sldasm" Then

      c = Left(OldName, Len(OldName) - 7)

  End If

'判断文件名是否含版本号,如果是，则分割版本号
BB = Right(c, 3)
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

         BB = Right(c, 2): c = Left(c, Len(c) - 3)

      Else

         BB = ""

      End If

End If
'下面是图号/国标号与零件名的分割
If Left(c, 5) = "XXXWG" Then    '如果前面是XXXWG，则判断为外购件

      e = Left(c, 11)             '外购件的编号为XXXWG□.□□□□,所以选前面11位为外购件编号

      q = 12

ElseIf Left(c, 2) = "XX" Then    '如果零件名前两位是"XX"，则判断XX后面是否为图号

      If Mid(c, 6, 1) <> "." Then b = c: goto FileName '如果从左边数起第6位不是"."，则判断为不带图号

      If Len(c) <= 5 Then b = c: goto FileName          '如果从左边数起第6位是"."，则判断3到5位是不是数字（按XX的图号命名规则，

      For i = 3 To 5                                  '3到5位是数字），如果不是，则不是图号

         a = Mid(c, i, 1)

         If (Asc(a) < 48 Or Asc(a) > 57) Then b = c: goto FileName

      Next i

      i = 7

      a = Mid(c, i, 1)

      If (Asc(a) < 48 Or Asc(a) > 57) Then b = c: goto FileName

      For q = i To Len(c)                                  '如果3到5位是数字，

         a = Mid(c, q, 1)

         j = Mid(c, q + 1, 1)

         If a = "." And (Asc(j) > 64 And Asc(j) < 91) Then '判断图号是否为修改版本(A-Z,
                                                            '其AscII码为65-90),如果是，
            e = Left(c, q + 1)                            '则将其后分割

            q = q + 2

            Exit For

         ElseIf (a = "_" Or ((Asc(a) < 48 Or Asc(a) > 57) And (Asc(j) < 48 Or Asc(j) > 57))) Then
                                             '如果文件名中含有分割符“_”，
            e = Left(c, q - 1)             '或者连续两个符号均不是数字，则分割

            Exit For

         End If

      Next q

ElseIf Left(c, 2) = "GB" Or Left(c, 2) = "JB" Then          '如果零件名前两位是"GB"或者"JB"，则以下过程为截取国标号

      q = InStr(4, c, "-")

      If (Mid(c, q + 1, 2) = "19" Or Mid(c, q + 1, 2) = "20") Then

         e = Left(c, q + 4)

         q = q + 5

   Else

         e = Left(c, q + 2)

         q = q + 3

      End If

End If

'截取零件名
If Left(c, 2) = "GB" Or Left(c, 2) = "JB" Or Left(c, 2) = "XX" Then

      If Mid(c, q, 1) = "_" Then                            '如果已经有分割符("_")，则

         b = Mid(c, q + 1)                               '分割符后为零件名

      Else                                                 '否则

         b = Mid(c, q)                                     '从当前位置分割

      End If

Else

      b = c    '如果图号或国标号为空，则零件名=文件名

End If

'将BT改为B／T, B/改为B／, 2位年份改为4位年份
If e <> "" Then

      a = Mid(e, 2, 2)

      If a = "BT" Then e = Replace(e, "BT", "B／T")    '将BT改为B／T

      If a = "B/" Then e = Replace(e, "B/", "B／")       '将B/改为B／

      a = Mid(Right(e, 3), 1, 1)

      If a = "-" Then e = Replace(e, "-", "-19")       '将2位年份改为4位年份

End If

FileName:
If e = "" And BB = "" Then FileName = b + t

If e = "" And BB <> "" Then FileName = b + "_" + BB + t

If e <> "" And BB = "" Then FileName = e + "_" + b + t

If e <> "" And BB <> "" Then FileName = e + "_" + b + "_" + BB + t
swModel.SaveAs (FilePath + FileName)

End Sub

tzydsfy · 发表于 2017-1-23 14:04:50

我正在找的,谢谢楼主

tzydsfy · 发表于 2017-2-5 09:21:24

真是高手

		自动登录	找回密码
密码			注册

通知

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

马上注册，结识高手，享用更多资源，轻松玩转三维网社区。