SW VBA填写文件属性

'定义Solidwork

Dim swApp As SldWorks.SldWorks

Dim swModel As SldWorks.ModelDoc2

Dim config As SldWorks.Configuration

Dim cusPropMgr As SldWorks.CustomPropertyManager

Dim ResolvedValOut As String

Dim ResolvedValOutArray As Variant

Dim IsAsm As Boolean

Dim PartName As String '名称→物料名称

Dim PartNameArray As Variant '模板名称列表

Dim Standard As String '代号→标准号

Dim PartNumber As String '图号，料号

Dim ProjectName As String '项目名称

Dim FileInfoDisplay As Boolean '属性界面信息

Dim PartPathName, PartTitle As String

Public Sub AutoPartNumberAndName()

ProjectName = GetProjectName '获取项目名称

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc

If swModel Is Nothing Then

MsgBox (\"没有可用的文件！\")

Exit Sub

End If

PartPathName = swModel.GetPathName() '零件名

If (PartPathName = \"\") Then

MsgBox (\"没有保存文件，请保存或另存为！\")

Exit Sub

End If

t = Right(PartPathName, 7)

If (t = \".SLDPRT\" Or t = \".sldprt\" Or t = \".SLDASM\" Or t = \".sldasm\") = False Then

MsgBox (\"文件类型必须为装配体或零件！\")

Exit Sub

End If

Set config = swModel.GetActiveConfiguration

Set cusPropMgr = config.CustomPropertyManager

PartTitle = swModel.GetTitle()

SpacePos = InStr(PartTitle, \" \") - 1 '分隔标识符位置

If Left(PartTitle, 2) = \"GB\" Then

Call ModifyMDProperty(cusPropMgr) '迈迪标准件的文件修改

ElseIf SpacePos <= 0 Then '如果没有分隔标识符

MsgBox (\"文件名中没有空格，请重命名！\" & Chr(10) & \"料号与物料名称以空格间隔，例：”014.J0.000.S0 定位夹具“\")

Exit Sub

Else

t = Right(PartTitle, 7)

If (t = \".SLDPRT\" Or t = \".sldprt\" Or t = \".SLDASM\" Or t = \".sldasm\") = False Then

PartTitle = PartTitle & Right(PartPathName, 7)

End If

Call PropertyNameInitial(cusPropMgr, PartTitle) '模板初始化

PartNumber = Left(PartTitle, SpacePos) '图号

b = Mid(PartTitle, SpacePos + 2)

t = Right(PartTitle, 7)

If t = \".SLDPRT\" Or t = \".sldprt\" Or t = \".SLDASM\" Or t = \".sldasm\" j = Len(b) - 7

Else

j = Len(b)

End If

If t = \".SLDASM\" Or t = \".sldasm\" Then

IsAsm = True

Else

IsAsm = False

End If

PartName = Left(b, j) '零部件名称

PointPos = InStr(PartTitle, \".\")

If PointPos > 0 And Mid(PartNumber, PointPos 3, 1) \".\" And

Then

+ =

Mid(PartNumber, PointPos + 7, 1) = \".\" Then

lRetVal = cusPropMgr.Set(\"料号\

lRetVal = cusPropMgr.Set(\"属性\自制\")

Else

lRetVal = cusPropMgr.Set(\"规格\

lRetVal = cusPropMgr.Set(\"属性\外购\")

lRetVal = cusPropMgr.Set(\"材料\

End If

If IsAsm Then

lRetVal = cusPropMgr.Set(\"材料\组件\")

End If

lRetVal = cusPropMgr.Set(\"项目名称\

lRetVal = cusPropMgr.Set(\"物料名称\

FileInfoDisplay = True

End If

'这里添加最后要执行的函数

If FileInfoDisplay Then

swModel.FileSummaryInfo

End If

swModel.Save

End Sub

Private Sub ModifyMDProperty(cusPropMgr) '迈迪标准件的文件属性修改

FileInfoDisplay = True

lRetVal = cusPropMgr.Add2(\"料号\swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"物料名称\

swCustomInfoType_e.swCustomInfoText, \"\")

'lRetVal = cusPropMgr.Add2(\"规格\swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"标准号\\"\")

'lRetVal = cusPropMgr.Add2(\"材料\swCustomInfoType_e.swCustomInfoText, Chr(34) & \"SW-Material@@Default@\" & PartTitle & Chr(34))

lRetVal = cusPropMgr.Add2(\"属性\swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"项目名称\

swCustomInfoType_e.swCustomInfoText, \"\")

'lRetVal = cusPropMgr.Add2(\"单重\swCustomInfoType_e.swCustomInfoText, Chr(34) & \"SW-Mass@@Default@\" & PartTitle & Chr(34))

lRetVal = cusPropMgr.Get2(\"名称\

lRetVal = cusPropMgr.Get2(\"代号\

lRetVal = cusPropMgr.Delete2(\"名称\")

lRetVal = cusPropMgr.Delete2(\"代号\")

lRetVal = cusPropMgr.Delete2(\"类别\")

lRetVal = cusPropMgr.Delete2(\"备注\")

lRetVal = cusPropMgr.Set(\"料号\

If PartName <> \"\" Then

lRetVal = cusPropMgr.Set(\"物料名称\

End If

If Standard <> \"\" Then

lRetVal = cusPropMgr.Set(\"标准号\

End If

If ProjectName <> \"\" Then

lRetVal = cusPropMgr.Set(\"项目名称\

End If

lRetVal = cusPropMgr.Get2(\"物料名称\

' If PartName = \"内六角圆柱头螺钉\" Then

' swModel.SetMaterialPropertyName2 \"默认\\"D:/SW-SR/wqw.sldmat\级\"

模板

' End If

lRetVal = cusPropMgr.Set(\"属性\外购\")

End Sub

Private Sub PropertyNameInitial(cusPropMgr, PartTitle)

lRetVal = cusPropMgr.GetAll2(PartNameArray, ResolvedValOutArray,

ResolvedValOutArray, ResolvedValOutArray) '获取模板名称列表

If lRetVal <> 0 Then

For i = LBound(PartNameArray) To UBound(PartNameArray)

lRetVal = cusPropMgr.Delete2(PartNameArray(i)) '删除模板名称列表

Next i

End If

lRetVal = cusPropMgr.Add2(\"料号\swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"物料名称\

swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"规格\swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"标准号\

swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"材料\swCustomInfoType_e.swCustomInfoText, Chr(34) & \"SW-Material@@Default@\" & PartTitle & Chr(34))

lRetVal = cusPropMgr.Add2(\"属性\swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"项目名称\

swCustomInfoType_e.swCustomInfoText, \"\")

lRetVal = cusPropMgr.Add2(\"单重\swCustomInfoType_e.swCustomInfoText, Chr(34) & \"SW-Mass@@Default@\" & PartTitle & Chr(34))

End Sub

Private Function GetProjectName()

Dim PathName, name As String

PathName = \"D:\\SW模板-SR\\项目名称.txt\"

Open PathName For Input Access Read As #1

'打开文件作为数据输入用，文件号为#1

' Do While Not EOF(1)

' Line Input #1, txt '从已打开的顺序文件中读出一行并将它分配给 String 变量

' 'Line Input # 语句一次只从文件中读出一个字符，直到遇到回车符 (Chr(13))

' '或回车–换行符 (Chr(13) + Chr(10)) 为止。回车–换行符将被跳过，而不会被附加到字符串上

' MsgBox txt

' Loop

If EOF(1) Then

MsgBox (\"没有“D:\\SW模板-SR\\项目名称.txt”文件或内容\")

Close #1

Exit Function

Else

Line Input #1, name

GetProjectName = name

End If

Close #1

End Function