solidworks模型自定义属性的批量处理的宏代码

(7人评价)|1036人阅读|24次下载|举报文档

'solidworks模型自定义属性的批量处理的宏代码
'本?文?本?是?由?b?a?s?文?档?编?辑?而?成?,?可?以?直?接?更?改?后?缀?为?.?b?a?s?导?入?宏?文?件?(?.?s?w?p?)?使?用
Attribute VB_Name = "利用子件处理属性1"
'利用子件进行自定义属性的批量处理的VBA代码
'比较完善的第一版完成时间2012.11.05，作者：张中锋
'适用于深圳东风有限公司solidworks老模型属性更改满足金蝶公司PLM系统要求实例
'测试通过环境：2012.11.05 windows XP SP3 ;solidworks 2010 SP02（32bit）

'''''''''''''''''''''''''''''''''''''''''''''''''
'版本更新日志
'1.0 2012.10.29 ①对属性中，存在空白情况处理时数据异常进行修复；②对于已经存在的自定义属性值，保护其值不被处理

'已知的bug记录

Public swModel2 As SldWorks.ModelDoc2
Public PARTNAME_Value_temp As String
Public MATERIAL_Value2_temp As String
Public swApp As SldWorks.SldWorks

Sub main()

Dim swModel As SldWorks.ModelDoc2
Dim swModelDocExt As SldWorks.ModelDocExtension
Dim swSelMgr As SldWorks.SelectionMgr
Dim swBOMAnnotation As SldWorks.BomTableAnnotation
Dim swBOMFeature As SldWorks.BomFeature
Dim swBomTable As Variant

Dim boolstatus As Boolean
Dim BomType As Long
Dim Configuration As String
Dim TemplateName As String
Dim i, j, n, k As Integer
Dim swBOM_name As String
Dim component As Component2
Dim value_temp As Integer

Dim time_start As String
Dim txt_path As String

Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

txt_path = swModel.GetPathName() " .csv"

Open txt_path For Output Shared As #400

Print #400, "图样代号"; ","; "零件名称"; ","; "零件材料"; Chr(10);

Configuration = swModel.GetActiveConfiguration().Name

If swModel.GetType = 1 Then

Set swModel2 = swApp.ActiveDoc
Call Custominfo_change(Configuration)

ElseIf swModel.GetType = 2 Then

value_temp = swModel.ResolveAllLightWeightComponents(False) '轻化取消到还原状态

Dim Components As Variant
Dim SingleComponent As Variant
Dim swComponent As SldWorks.Component2

Components = swModel.GetComponents(False) '获取整个装配体的组成部件（零件或者装配体）

For Each SingleComponent In Components '遍历

Set swComponent = SingleComponent

If Not swComponent Is Nothing Then

If swComponent.GetModelDoc() Is Nothing Then '判断子件对象模型是否存在；轻化状态下获取不到，为空

Debug.Print "没有通过"

Else
Dim x As Integer
Do '此循环实现处理当前模型和子件属性

If Not swComponent Is Nothing And x 99 Then '一个很原始的方法强制使用当前的模型

Set swModel2 = swModel
x = 100
Else

Set swModel2 = swComponent.GetModelDoc() '取得子件对象模型

x = 101
End If

Call Custominfo_change(swModel2.GetActiveConfiguration().Name)

Loop Until x = 101
End If

Else
Debug.Print " 不能获取到子件"
End If
Next

Else
MsgBox "不是零件或者装配体模型"
End If
swModel.Save '保存文件

Close #400

MsgBox "属性转换完毕"

End Sub

Private Function Custominfo_change(ByVal vConfigName As String) '处理模型的属性
Dim vConfigNameArr As Variant
Dim vCustInfoNameArr As Variant
Dim vCustInfoName As Variant
Dim vCustInfoName2 As Variant
Dim vCustInfoNameArr2 As Variant
Dim vCustInfoName2_temp As String
Dim vCustInfoName_temp As String
Dim a() As String
Dim b() As String
Dim m, n As Integer

vCustInfonameArr = swModel2.GetCustomInfoNames2(vConfigName)
vCustInfoNameArr2 = swModel2.GetCustomInfoNames

m = 0
If Not IsEmpty(vCustInfoNameArr2) Then '取得自定义属性表的属性数据
For Each vCustInfoName2 In vCustInfoNameArr2
vCustInfoName2_temp = CStr(vCustInfoName2)
If vCustInfoName2_temp = "" Then '处理属性表中的空白数据行
m = m - 1
ReDim Preserve a(1, m)
Exit For
End If

vCustInfoName_temp_value2 = swModel2.CustomInfo(vCustInfoName2)
ReDim Preserve a(1, m)
a(0, m) = Trim(vCustInfoName2_temp)
a(1, m) = Trim(vCustInfoName_temp_value2)
m = m + 1
ReDim Preserve a(1, m)

Next
End If

n = 0
If Not IsEmpty(vCustInfoNameArr) Then '取得配置特定属性表的属性数据
For Each vCustInfoname In vCustInfoNameArr
vCustInfoName_temp = CStr(vCustInfoName)
If vCustInfoName_temp = "" Then '处理属性表中的空白数据行
n = n - 1
ReDim Preserve b(1, n)
Exit For
End If

vCustInfoName_temp_value = swModel2.CustomInfo2(vConfigName, vCustInfoName)

ReDim Preserve b(1, n)
b(0, n) = Trim(vCustInfoName_temp)
b(1, n) = Trim(vCustInfoName_temp_value)
n = n + 1
ReDim Preserve b(1, n)

Next
End If

Dim s, t As Integer

If m 0 Then '当数组a中有数据时

For s = 0 To UBound(a, 2) '循环取出a中存储的每一条数据

If a(0, s) "" And a(1, s) "" Then '当数据有效时

Call OldCustominfo_Value(a(0, s), a(1, s), "PARTNAME")

ElseIf a(0, s) = "" Then '当数据无效时（此情况只会是取得最后一条数据时）
Exit For
End If

Next s

If PARTNAME_Value_temp = "" Then '在a中没有获取到合适的数据

If n 0 Then
For t = 0 To UBound(b, 2) '循环取出b中存储的每一条数据

If b(0, t) "" And b(1, t) "" Then '当数据有效时

Call OldCustominfo_Value(b(0, t), b(1, t), "PARTNAME")

ElseIf b(0, t) = "" Then '当数据无效时（此情况只会是取得最后一条数据时）
Exit For

End If

Next t

End If
End If
End If

If m 0 Then

For s = 0 To UBound(a, 2)

If a(0, s) "" And a(1, s) "" Then

Call OldCustominfo_Value(a(0, s), a(1, s), "MATERIAL")

ElseIf a(0, s) = "" Then

Exit For
End If

Next s

If MATERIAL_Value2_temp = "" Then

If n 0 Then
For t = 0 To UBound(b, 2)

If b(0, t) "" And b(1, t) "" Then

Call OldCustominfo_Value(b(0, t), b(1, t), "MATERIAL")

ElseIf b(0, t) = "" Then

Exit For

End If

Next t

End If
End If
End If

Dim DRAWNO_value As String
Dim PARTNAME_value As String
Dim MATERIAL_value As String

PARTNAME_value = Trim(PARTNAME_Value_temp)
MATERIAL_value = Trim(MATERIAL_Value2_temp)

'使用模型的绝对路径获取文件图号，比使用标题更安全
Dim DRAWNO_value1, DRAWNO_value2, DRAWNO_value13 As String
Dim DRAWNO_value_N As Integer

DRAWNO_value1 = swModel2.GetPathName
DRAWNO_value2 = StrReverse(DRAWNO_value1)
DRAWNO_value_N = InStr(1, DRAWNO_value2, "\")
DRAWNO_value3 = Mid(DRAWNO_value2, 8, DRAWNO_value_N - 8)
DRAWNO_value = StrReverse(DRAWNO_value3)

If Not IsEmpty(vCustInfoNameArr2) Then
For Each vCustInfoName2 In vCustInfoNameArr2 '删除自定义属性
bRet = swModel2.DeleteCustomInfo(vCustInfoName2)

Next

End If

swModel2.AddCustomInfo3 "", "DRAWNO", swCustomInfoText, DRAWNO_value '写入图样代号DRAWNO
swModel2.AddCustomInfo3 "", "PARTNAME", swCustomInfoText, PARTNAME_value '写入零件名称PARTNAME
Call new_unit

If Trim(Left(DRAWNO_value, 1)) "Q" And Trim(Left(DRAWNO_value, 2)) "GB" Then '检查标准件

swModel2.AddCustomInfo3 "", "MATERIAL", swCustomInfoText, MATERIAL_value '写入零件材料MATERIAL

Call new_Material

Weight_value = Show_mass(swModel2.GetPathName) '获取零件重量的数值
swModel2.AddCustomInfo3 "", "Weight", swCustomInfoText, Format(Weight_value, "0.0") '写入零件重量Weight,使用1位小数"
swModel2.AddCustomInfo3 "", "SPEC", swCustomInfoText, " "
swModel2.AddCustomInfo3 "", "REMARK", swCustomInfoText, " "

End If

Print #400, DRAWNO_value; ","; PARTNAME_value; ","; MATERIAL_value; Chr(10);

PARTNAME_Value_temp = ""
MATERIAL_Value2_temp = ""

End Function

Private Function new_unit() '更改单位
Dim boolstatus As Boolean

boolstatus = swModel2.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitSystem, 0, swUnitSystem_e.swUnitSystem_Custom)
boolstatus = swModel2.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsLinearFractionDenominator, 0, 0)
boolstatus = swModel2.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsLinearFeetAndInchesFormat, 0, False)
boolstatus = swModel2.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsDualLinearFractionDenominator, 0, 0)
boolstatus = swModel2.Extension.SetUserPreferenceToggle(swUserPreferenceToggle_e.swUnitsDualLinearFeetAndInchesFormat, 0, False)
boolstatus = swModel2.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropDecimalPlaces, 0, 1)
boolstatus = swModel2.Extension.SetUserPreferenceInteger(swUserPreferenceIntegerValue_e.swUnitsMassPropMass, 0, swUnitsMassPropMass_e.swUnitsMassPropMass_Kilograms)

End Function

Private Function new_Material() '更改材质
Dim matDbs As Variant
Dim swPart As Object
Dim MaterialDatabase As String
Dim MATERIAL_value_temp As String
Dim reval As Boolean

'判断当前的模型文件类型
If swModel2.GetType() = 1 Then 'swModel_filename_value 值为1时，打开零件模型
matDbs = swApp.GetMaterialDatabases
Set swPart = swModel2

MaterialDatabase = matDbs(0)

MATERIAL_value_temp = swPart.GetMaterialPropertyName2(Configuration_Name, MaterialDatabase) '获取模型树中的材质值

If MATERIAL_value_temp = "" Then '如果没有指定材质，材质默认为普通碳钢

reval = swModel2.SetMaterialPropertyName2(Configuration_Name, MaterialDatabase, "普通碳钢")
swModel2.ClearSelection2 True

End If
End If
End Function

Private Function OldCustominfo_Value(ByVal temp11 As String, ByVal temp22 As String, ByVal temp23) As String '处理旧自定义属性及值

OldCustominfo_Value = ""

If Trim(temp22) "" And Left(Trim(temp22), 1) Chr(34) Then

If temp23 = "PARTNAME" Then '如果调用的参数为 PARTNAME，需要处理的变量为 PARTNAME_value_temp，赋相关值

If temp11 = "PARTNAME" And Left(Trim(temp22), 1) "名" And Left(Trim(temp22), 1) "D" And Left(Trim(temp22), 1) "零" Then

PARTNAME_Value_temp = Trim(temp22)
OldCustominfo_Value = PARTNAME_Value_temp
ElseIf temp11 = "图样名称" Or temp11 = "零件名称" Or temp11 = "名称" Then
If Left(Trim(temp22), 1) "D" And Left(Trim(temp22), 1) "零" And Left(Trim(temp22), 1) "装" And Left(Trim(temp22), 1) "名" Then

PARTNAME_Value_temp = Trim(temp22)
OldCustominfo_Value = PARTNAME_Value_temp

Else
OldCustominfo_Value = ""

End If
Else
OldCustominfo_Value = ""
End If

ElseIf temp23 = "MATERIAL" Then '如果调用的参数为 MATERIAL，要处理的变量为 MATERIAL_value_temp，赋相关值
If temp11 = "MATERIAL" And Left(Trim(temp22), 1) "材" And Left(Trim(temp22), 1) "D" And Left(Trim(temp22), 1) "零" Then

MATERIAL_Value2_temp = Trim(temp22)
OldCustominfo_Value = MATERIAL_Value2_temp
ElseIf temp11 = "材料名称" Or temp11 = "零件材料" Or temp11 = "材料" Then
temp33 = Left(Trim(temp22), 1)
If temp33 = "钢" Or temp33 = "4" Or temp33 = "1" Or temp33 = "2" Or temp33 = "Q" Or temp33 = "总" Or temp33 = "部" Or temp33 = "橡" _
Or temp33 = "尼" Or temp33 = "组" Or temp33 = "圆" Or temp33 = "方" Or temp33 = "焊" Or temp33 = "装" Or temp33 = "合" Or temp33 = "高" _
Or temp33 = "角" Or temp33 = "扁" Or temp33 = "热" Or temp33 = "冷" Or temp33 = "外" Or temp33 = "分" Or temp23 = "有" Then

MATERIAL_Value2_temp = value_G(Trim(temp22))
OldCustominfo_Value = MATERIAL_Value2_temp
Else
OldCustominfo_Value = ""
End If
Else
OldCustominfo_Value = ""
End If
End If
Else
OldCustominfo_Value = ""
End If

End Function

Private Function value_G(ByVal value_G_in As String) As String '处理零件材料的值中的国标号
Dim value_G_temp As String
Dim value_G_out As String
Dim G_nomber As Integer

value_G_temp = Trim(value_G_in) '删除变量中开头和结尾的空白字符
G_nomber = InStr(value_G_temp, "G") '查找字符“G”的第一次出现的位置
If G_nomber 1 Then '如果获得“G”
value_G_out = Left(value_G_temp, G_nomber - 1) '获得字符“G”之前的字符串
If value_G_out = "" Then
value_G = "" '返回一个空值，没有取得值"
Else
value_G = value_G_out
End If
Else '没有字符“G”
value_G = value_G_temp
End If
End Function

Private Function Show_mass(ByVal DRAWNO_value11 As String) As String '获取质量的数值
Dim DRAWNO_value12, DRAWNO_value113 As String
Dim DRAWNO_value1_N As Integer

DRAWNO_value12 = StrReverse(DRAWNO_value11)
DRAWNO_value1_N = InStr(1, DRAWNO_value12, "\")
DRAWNO_value13 = Mid(DRAWNO_value12, 1, DRAWNO_value1_N)
DRAWNO_value1 = StrReverse(DRAWNO_value13)
Show_mass = Chr(34) "SW-Mass@" DRAWNO_value1 + Chr(34)

End Function