分享两个宏，有详细注解，可尽情修改使用，代码也一起放了。

tg-000057 · 发表于 2021-1-13 14:11:47

工程图转格式:

Dim swApp As Object
Dim Part As Object
Dim Filename As String
Dim No As Integer
Dim Title As String '以上设定变量
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc '以上交换数据
Filename = Part.GetPathName() 'Filename为文件名
No = Len(Filename) 'no为工程图文件名字符串总数
If No > 0 Then '当NO大于0时（转换格式名称是工程图名称，故要先保存工程图才可转换，工程图未保存无名称，无字符串，不可进行一下步)
Filename = Left(Filename, No - 7) + "." + Right(Filename, 1) '字串符操作，no-7为去掉工程图后缀名，"."+ right（filename,1）为增加后缀名最后一个字母作为识别，用于区别客户来图，可不要
Part.SaveAs2 Filename & ".dwg", 0, True, False '输出需要转换的格式文件，已有文件则自动替换，不提示，（有些格式文件在打开状态中不可替换，替换不成功也不提示)
Part.SaveAs2 Filename & ".pdf", 0, True, False
End If
End Sub

属性改写宏:

Sub main()

Dim swApp As SldWorks.SldWorks
Dim swModel2 As SldWorks.ModelDoc2
Dim SelMgr As SldWorks.SelectionMgr
Dim vCustInfoNameArr2 As Variant
Dim vCustInfoName2 As Variant
Dim CurCFGname As Variant
Dim CurCFGnameCount As Integer
Dim Vnamearr As Variant
Dim CusPropMgr As CustomPropertyManager
Dim bRet As Boolean
Dim Vnamearr2 As Variant

Dim strmat As String
Dim tempvalue As String

Set swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
Set SelMgr = swModel2.SelectionManager '

Dim tg1 As String
Dim tg2 As String
Dim tg3 As String
Dim tg4 As String
Dim tg5 As String
Dim tg6 As String
Dim tg7 As String
Dim tg8 As String
Dim tg9 As String
Dim tg10 As String
Dim tg11 As String
Dim wm As String
Dim wm1 As Integer
Dim wm2 As String
Dim wm3 As String
Dim wm4 As String
Dim wm5 As String
Dim wm6 As String
Dim wm7 As Integer
Dim wm8 As String
Dim wm9 As Integer
Dim lz As String
Dim lz1 As Integer
Dim lz2 As String
Dim lz3 As String
Dim lz4 As Integer
Dim lz5 As Integer
Dim lz6 As String
Dim lz7 As Integer '以上为设定变量

swApp.ActiveDoc.ActiveView.FrameState = 1
vCustInfoNameArr2 = swModel2.GetCustomInfoNames
If Not IsEmpty(vCustInfoNameArr2) Then
For Each vCustInfoName2 In vCustInfoNameArr2
bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
Next
End If '此段是删除自定属性中的所有项和其项值

CurCFGname = swModel2.GetConfigurationNames
CurCFGnameCount = swModel2.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
Set CusPropMgr = swModel2.Extension.CustomPropertyManager(CurCFGname(i))
Vnamearr = CusPropMgr.GetNames
If Not IsEmpty(Vnamearr) Then
For Each Vnamearr2 In Vnamearr
bRet = swModel2.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
Next
End If
Next '此断是删除其他配置中的属性所有项和其项值

wm = swApp.ActiveDoc.GetTitle() '定义是文件名
lz = swApp.ActiveDoc.GetPathName() '定义为文件路径
tg6 = Chr(34) + Trim("SW-Material" + "@") + wm + Chr(34) '定义材料属性
tg7 = Chr(34) + Trim("厚度" + "@") + wm + Chr(34) '定义钣金厚度属性
tg8 = Chr(34) + Trim("SW-Mass" + "@") + wm + Chr(34) + "kg" '定义质量属性
tg9 = Chr(34) + Trim("SW-SurfaceArea" + "@") + wm + Chr(34) + "㎡" '定义表面积属性
bRet = swModel2.DeleteCustomInfo2("", "图号")
bRet = swModel2.DeleteCustomInfo2("", "Description")

wm1 = InStrRev(wm, " ") - 1 '引号内为空格，为图名分离符号 '从右向左搜索到第一个" "符号为第几个字串符
If wm1 > 0 Then '当mw1大于0量时
wm2 = Left(wm, wm1) 'wm2等于从wm的左侧开始提取mw1个字符
wm3 = Left(LTrim(wm), 3) 'wm等于wm去除左侧无效字符的左前三个字符
If wm3 = "GBT" Then '当wm3等于"GBT"时
wm4 = "GB/T" + Mid(wm2, 4) 'wm4等于"GB/T"和wm2的第4个和后面的所有字符 '当零件是国标时添加国标号，文件名中/是非法字符
Else
wm4 = wm2 '否则wm4等wm2 '空格前面是图号
End If

wm5 = Mid(wm, wm1 + 2) 'wm5等于wm中的第wm1+2个后面的所有字符
wm6 = Right(wm, 7) 'wm6等于wm最后面的7个字符
If wm6 = ".SLDPRT" Or wm6 = ".SLDASM" Or wm6 = ".sldprt" Or wm6 = ".sldasm" Then '当wm6等于这4个值时
wm7 = Len(wm5) - 7 'wm7等于wm5的所有字符数-7
Else
wm7 = Len(wm5) '否则wm7等于wm5的所有字符数
End If
tg5 = Left(wm5, wm7) 'tg5等于wm5左侧的wm7个字符 ,空格后面是名称，有后缀名并去掉后缀名，无后缀后（文件未保存时)直接上档

End If '此段为图名分离定义

If wm1 > 0 Then '当wm1大于0时
tg4 = wm4 'tg4等于wm4 '文件名有空格时，图号为分离出来图号
Else
wm8 = Right(wm, 7) 'wm8等于wm最后面的7个字符
If wm8 = ".SLDPRT" Or wm8 = ".SLDASM" Or wm8 = ".sldprt" Or wm8 = ".sldasm" Then '当wm8等于这4个值时
wm9 = Len(wm) - 7 'wm9等于wm的所有字符数-7
Else
wm9 = Len(wm)
End If '否则wm9等于wm所有字符数-7
tg4 = Left(wm, wm9) 'tg4等于wm左侧的wm9个字符 '文件无空格时，文件名即是图号，并去掉后缀名,无后缀名（文件未保存时)直接上档
End If '此段为非图号名称命名文件，将文件名加到图号属性
'例，fgq01-001 前门板：分离后图号（fgq-001），名称（前门板)
'例，fgq01-001 前门板：分离后图号（fgq-001 前），名称（门板)
'例，fgq01-001-前门板：分离后图号（fgq-001-前门板），名称为空
'以最后一个空格为准分离

lz1 = InStrRev(lz, "--") 'lz1为lz由后向前搜索到第一个"--"字符在第几个
If lz1 > 0 Then '当lz1大于0时
lz2 = Mid(lz, lz1 - 8, 8) 'lz2等于lz的第lz1-8个和其后面8个字符
lz3 = Mid(lz, lz1 + 2) 'lz3等于lz的第lz2+2个后其后面所有字符
lz4 = InStrRev(lz2, "\") 'lz4为lz2由后向前搜索到第一个"\"字符在第几个
lz5 = InStr(lz3, "\") 'lz5为lz2由前向后搜索到第一个"\"字符在第几个
tg1 = Mid(lz2, lz4 + 1) 'tg1等于lz2的第lz4+1个后面的所有字符
'tg1 = Right(lz2, 8 - lz4) 'tg1等于lz2右侧的8-lz4个字符(lz2总字符为8个)
tg2 = Left(lz3, lz5 - 1) 'tg2等于lz3左侧的lz5-1个字符

lz6 = Mid(lz3, lz5 + 1) 'lz6等于lz3第lz5+1个后面的所有字符
lz7 = InStr(lz6, "\") 'lz7为lz6由左向右搜索出第一个"\"字符在第几个
If lz7 > 0 Then '当lz7大于0时
tg3 = Left(lz6, lz7 - 1) 'tg3等于lz6左侧的lz7-1个字符
End If
End If '此段为文件路径提取项目号
'例，零件文件完整路径为：E:\工作文档\B-非标产品\非标--F类\FGQ--定制角架\2020版\前门板.SLDPRT
'由后向前搜索“--”,第一个“--”向前到“\”间为产品编号（FGQ），向后到“\”间为产品名称（定制角架），向后的第一个“\”和第二个间“\”，为版本号(2020版)。

bRet = swModel2.AddCustomInfo3("", "产品编号", swCustomInfoText, tg1)
bRet = swModel2.AddCustomInfo3("", "产品名称", swCustomInfoText, tg2)
bRet = swModel2.AddCustomInfo3("", "版本号", swCustomInfoText, tg3)
bRet = swModel2.AddCustomInfo3("", "图号", swCustomInfoText, tg4)
bRet = swModel2.AddCustomInfo3("", "Description", swCustomInfoText, tg5)
bRet = swModel2.AddCustomInfo3("", "数量", swCustomInfoText, "1")
bRet = swModel2.AddCustomInfo3("", "备注1", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "备注2", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "备注3", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "Material", swCustomInfoText, tg6)
bRet = swModel2.AddCustomInfo3("", "SH", swCustomInfoText, tg7)
bRet = swModel2.AddCustomInfo3("", "重量", swCustomInfoText, tg8)
bRet = swModel2.AddCustomInfo3("", "表面积", swCustomInfoText, tg9) '此段为填写自定义属性项与其值

Dim thisFeat As SldWorks.Feature '另外增加一段宏，取读取切割清单数据，并添加到属性项。
Dim thisSubFeat As SldWorks.Feature
Dim cutFolder As Object
Dim BodyCount As Integer
Dim custPropMgr As SldWorks.CustomPropertyManager
Dim propNames As Variant
Dim vName As Variant
Dim propName As String
Dim Value As String
Dim resolvedValue As String
Dim bjkcd As Double
Dim bjkkd As Double
'Sub main()
'Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set thisFeat = Part.FirstFeature
Do While Not thisFeat Is Nothing '遍历设计树
If thisFeat.GetTypeName = "SolidBodyFolder" Then
thisFeat.GetSpecificFeature2.UpdateCutList
End If
Set thisSubFeat = thisFeat.GetFirstSubFeature
Do While Not thisSubFeat Is Nothing
If thisSubFeat.GetTypeName = "CutListFolder" Then '查找切割清单
Set cutFolder = thisSubFeat.GetSpecificFeature2
End If
If Not cutFolder Is Nothing Then
BodyCount = cutFolder.GetBodyCount
If BodyCount > 0 Then
Set custPropMgr = thisSubFeat.CustomPropertyManager
If Not custPropMgr Is Nothing Then
propNames = custPropMgr.GetNames '获取切割清单属性的数据全部名称并放入数组
If Not IsEmpty(propNames) Then
For Each vName In propNames
propName = vName
custPropMgr.Get2 propName, Value, resolvedValue '获取全部属性名称，数值和评估的值
If propName = "边界框长度" Then bjkcd = resolvedValue '判断是否是自己所需要的数据，如果是就获取
If propName = "边界框宽度" Then bjkkd = resolvedValue
Next vName
End If
End If
End If
End If
Set thisSubFeat = thisSubFeat.GetNextSubFeature
Loop
Set thisFeat = thisFeat.GetNextFeature
Loop
'blnretval = Part.DeleteCustomInfo2("", "边界框长度") '删除属性栏上摘要信息的数据
'blnretval = Part.DeleteCustomInfo2("", "边界框宽度")
blnretval = Part.AddCustomInfo3("", "开料长度", swCustomInfoText, bjkcd) '添加数据到摘要信息
blnretval = Part.AddCustomInfo3("", "开料宽度", swCustomInfoText, bjkkd)

End Sub

远祥 · 发表于 2021-1-13 16:28:08

挺复杂啊，比较难用吧？？

晓昀 · 发表于 2021-1-13 17:17:50

这个是不是CAD转pdf的？佩服做软件二次开发的人。

柴荣1917 · 发表于 2021-1-13 17:29:04

学习一下。

tg-000057 · 发表于 2021-1-13 17:40:43

晓昀发表于 2021-1-13 17:17
: N. e# R# {1 G) p4 A这个是不是CAD转pdf的？佩服做软件二次开发的人。

cad转PDF，用cad的PDF打印机就行了，这个是sw转dwg，dxf，和pdf等格式的。

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

分享两个宏，有详细注解，可尽情修改使用，代码也一起放了。

本帖子中包含更多资源

点评