第2个回答 2018-05-16
Dim swApp As Object
Dim Part As Object
Dim Filename As String
Dim No As Integer
Dim Title As String
Dim swModel As ModelDoc2
Dim vCustInfoNameArr2 As Variant
Dim cpm As CustomPropertyManager
Dim a As Integer
Dim b As String
Dim name As String
Dim partnumber As String
Dim k As String
Dim t As String
Dim shortdate As String
Dim j As Integer
Dim Patch As String
Dim CustPropMgr As SldWorks.CustomPropertyManager
Dim vCustInfoNameArr3 As Variant
Sub main() '先删除自定义属性,在给自定义属性赋值
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
Set Part = swApp.ActiveDoc
Set cpm = swModel.Extension.CustomPropertyManager("")
vCustInfoNameArr2 = swModel.GetCustomInfoNames
If Not IsEmpty(vCustInfoNameArr2) Then
For Each vCustInfoName2 In vCustInfoNameArr2
bRet = swModel.DeleteCustomInfo(vCustInfoName2)
Next
End If
'(以上为删除自定义属性里所有内容)
Title = swApp.ActiveDoc.GetTitle() '提取零件名
j = Len(Title) - 6
Title = Left(Title, j)
Patch = swApp.ActiveDoc.GetPathName() '取得"路径名称及扩展名"(不管扩展名是否隐藏)
shortdate = Chr(36) + "PRP" + Chr(58) + Chr(34) + "SW-Short Date" + Chr(34) '设定当前短日期
a = InStr(Title, "-") - 1 '提取-字符个数
If a > 0 Then '判定a是否为空
k = Left(Title, a) 'K为文件名从左开始a个字符文字
partnumber = k
b = Mid(Title, a + 2) 'b的内容是从零件名的第A+2个字符开始截取(内容,第几个开始,截取长度)
t = Right(Title, 7) '从文件名右侧开始提取7个字符文字设为t
If t = ".SLDPRT" Or t = ".SLDASM" Then
j = Len(b) - 7 '如果t是SW零件或SW装配体则j的长度为b长度-7
Else
j = Len(b) '否则j的长度为b的长度
End If
name = Left(b, j)
Else
partnumber = ""
b = Mid(Title, a + 2) 'b的内容是从零件名的第A+2个字符开始截取(内容,第几个开始,截取长度)
t = Right(Title, 7) '从文件名右侧开始提取7个字符文字设为t
If t = ".SLDPRT" Or t = ".SLDASM" Then
j = Len(b) - 7 '如果t是SW零件或SW装配体则j的长度为b长度-7
Else
j = Len(b) '否则j的长度为b的长度
End If
name = Left(b, j)
End If
Patch = Left(Patch, InStrRev(Patch, "\", -1)) '提出路径
Dim G
Dim H
Dim Projectnumber As String
Dim Projectname As String
Dim q As String
Dim r As String
Dim u As String
Dim y As String
G = Split(Patch, "\") '将路径用\分割
H = UBound(G) - 1 '提取最后一段是第几段,则G(H)就是最后一段里的内容
q = InStr(G(H), "-") - 1
If q > 0 Then
Projectnumber = Left(G(H), q)
r = Mid(G(H), q + 2)
y = Len(r)
Projectname = Left(r, y)
End If
cpm.Add2 "Part Number", swCustomInfoText, partnumber
cpm.Add2 "Name", swCustomInfoText, name
cpm.Add2 "Material", swCustomInfoText, """SW-Material@" & Title & ".SLDPRT"""
cpm.Add2 "Weight", swCustomInfoText, """SW-Mass@" & Title & ".SLDPRT"""
cpm.Add2 "Revision", swCustomInfoText, " "
cpm.Add2 "Author", swCustomInfoText, ""
cpm.Add2 "Author Date", swCustomInfoText, shortdate
cpm.Add2 "Project number", swCustomInfoText, Projectnumber
cpm.Add2 "Project Name", swCustomInfoText, Projectname
cpm.Add2 "Description", swCustomInfoText, " "
'另存为IGS文件
Filename = Part.GetPathName()
No = Len(Filename)
Filename = Left(Filename, No - 7)
Part.SaveAs2 Filename & ".IGS", 0, True, False
Title = Part.GetTitle
Part.Save '保存
'swApp.CloseDoc Title
'X = MsgBox("输出pdf文件在SW工程图同一文件夹", 0)
End Sub