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

大隆数控 · 发表于 2016-7-9 12:41:40

经典图书

'本程序自动将零件以“图号(国标号)_零件名_版本”的格式保存；
'注意：
'①零件名不能以数字开头和结尾；
'②零件名内不能有空格、全角的“·”；
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))  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