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

tg-000057

' T9 M. ?* h1 v6 n6 f' }! n9 G工程图转格式:

0 r6 V8 o/ q! O/ Y# {" M  L
0 Z% ]9 Y; t) g5 z& VDim swApp As Object
0 d! x& P% Q$ a, b. \( }6 O1 ~Dim Part As Object
Dim Filename As String
Dim No As Integer
Dim Title As String          '以上设定变量
Sub main()
, k2 i( F/ d, O# VSet swApp = Application.SldWorks
5 k7 i3 T. v7 [% l+ Z* ^' g" g. iSet Part = swApp.ActiveDoc                                                  '以上交换数据
5 ]- M* d; k# N8 F( gFilename = Part.GetPathName()                                               'Filename为文件名
0 Y( h$ g7 _" ZNo = Len(Filename)                                                          'no为工程图文件名字符串总数
If No > 0 Then                                                              '当NO大于0时（转换格式名称是工程图名称，故要先保存工程图才可转换，工程图未保存无名称，无字符串，不可进行一下步)
Filename = Left(Filename, No - 7) + "." + Right(Filename, 1)                '字串符操作，no-7为去掉工程图后缀名，"."+ right（filename,1）为增加后缀名最后一个字母作为识别，用于区别客户来图，可不要
. c2 u& E( ^; r4 b1 IPart.SaveAs2 Filename & ".dwg", 0, True, False                              '输出需要转换的格式文件，已有文件则自动替换，不提示，（有些格式文件在打开状态中不可替换，替换不成功也不提示)
6 \2 y: s, E9 l& X, kPart.SaveAs2 Filename & ".pdf", 0, True, False
) a3 B% c8 G- L0 H1 g# N) M4 _End If
End Sub

" x2 B) S( H5 S( ^

* n, L. Z$ V1 p8 M! w属性改写宏:
! {9 m7 ^: i, Z% V1 m6 W2 k

0 {, x4 b/ }7 D+ q# O1 [/ T
$ M8 B4 i+ s$ j' A+ w4 ISub main()

Dim swApp As SldWorks.SldWorks
Dim swModel2 As SldWorks.ModelDoc2
Dim SelMgr As SldWorks.SelectionMgr
9 Y3 r6 S; g) r& o. UDim vCustInfoNameArr2 As Variant
- Q1 ]: N3 }+ v) d& ~' ]Dim vCustInfoName2 As Variant
Dim CurCFGname As Variant
Dim CurCFGnameCount As Integer
9 K2 b/ ~! ?9 Y1 D  g6 qDim Vnamearr As Variant
9 t6 o4 t/ G0 T' g8 `Dim CusPropMgr As CustomPropertyManager
) H* w1 _6 W8 b. o% ODim bRet As Boolean
/ ?# E6 U; ?; G; w+ y& @Dim Vnamearr2 As Variant

Dim strmat As String
; W& M* n* v) @Dim tempvalue As String
: _6 g3 W% w9 m4 G! j1 J, k
' l4 ?; T" B, a( u+ U; [- jSet swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
7 x2 L/ `2 R/ p, }6 d8 KSet SelMgr = swModel2.SelectionManager '

Dim tg1 As String
Dim tg2 As String
3 }& T8 W2 u; G7 g: f: x% HDim tg3 As String
, X) U& {. Z+ {7 dDim tg4 As String
3 B! e- w3 P& }+ T5 p( H9 QDim tg5 As String
Dim tg6 As String
Dim tg7 As String
Dim tg8 As String
! V1 f( m( A1 ]1 m2 c8 t2 `Dim tg9 As String
Dim tg10 As String
5 i' K- D$ F. {3 FDim tg11 As String
Dim wm As String
Dim wm1 As Integer
& \( x: h7 w1 Z5 @Dim wm2 As String
Dim wm3 As String
0 j- y) n9 g+ C- c: LDim wm4 As String
Dim wm5 As String
Dim wm6 As String
* V7 R& M* s2 EDim wm7 As Integer
Dim wm8 As String
Dim wm9 As Integer
+ }1 K4 I% T* w: B0 O0 u3 nDim lz As String
Dim lz1 As Integer
Dim lz2 As String
% x' `  v+ V$ D4 a% jDim lz3 As String
Dim lz4 As Integer
4 o" i9 F: n# |' Y8 ?Dim lz5 As Integer
4 w4 E& y; e9 W) R7 cDim lz6 As String
4 G4 r* \* M( m1 ?Dim lz7 As Integer                                                                     '以上为设定变量


' J8 V+ h' {: _+ T3 p! JswApp.ActiveDoc.ActiveView.FrameState = 1
- _6 n2 D  k- ]% I! w7 O6 y7 m' vvCustInfoNameArr2 = swModel2.GetCustomInfoNames
  If Not IsEmpty(vCustInfoNameArr2) Then
& d0 \: W0 ~/ D+ Y* V5 t) r     For Each vCustInfoName2 In vCustInfoNameArr2
         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
      Next
, ^  H$ D+ r! F  End If                                                                               '此段是删除自定属性中的所有项和其项值

6 {2 M7 K, \+ a2 R/ ^% I, a! [
2 k: ?* Q  ]/ c9 D* J4 l2 UCurCFGname = swModel2.GetConfigurationNames
0 S$ Z4 {1 \' u9 ?7 R3 ~" K7 lCurCFGnameCount = swModel2.GetConfigurationCount
. R: s5 N9 k3 |2 M+ ZFor i = 0 To CurCFGnameCount - 1
2 H3 m7 ?+ L' R! O; F' [3 P    Set CusPropMgr = swModel2.Extension.CustomPropertyManager(CurCFGname(i))
    Vnamearr = CusPropMgr.GetNames
, ?4 d4 ^8 b: z0 L    If Not IsEmpty(Vnamearr) Then
' g- \- [6 E: L0 F( }: B( N8 o        For Each Vnamearr2 In Vnamearr
* O5 z$ T/ p/ v( [; {# z3 p            bRet = swModel2.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
2 F) t- ~( Y* v* f        Next
& \8 N- K) _; K5 J0 s    End If
    Next                                                                               '此断是删除其他配置中的属性所有项和其项值


# f0 @/ [! J0 u9 r6 T" a$ G% q3 jwm = swApp.ActiveDoc.GetTitle()                                                         '定义是文件名
lz = swApp.ActiveDoc.GetPathName()                                                      '定义为文件路径
, C+ K% v) h3 p$ L3 `3 c% |# rtg6 = 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) + "㎡"                      '定义表面积属性
" N( A2 }! v) EbRet = swModel2.DeleteCustomInfo2("", "图号")
bRet = swModel2.DeleteCustomInfo2("", "Description")

7 ~& D% b) I$ p. A5 B: }
- g9 u$ v6 g* v' l7 w$ |/ t( lwm1 = InStrRev(wm, " ") - 1                                                              '引号内为空格，为图名分离符号        '从右向左搜索到第一个" "符号为第几个字串符
If wm1 > 0 Then                                                                          '当mw1大于0量时
. D, v+ ~2 Q) Q7 s    wm2 = Left(wm, wm1)                                                                  'wm2等于从wm的左侧开始提取mw1个字符
    wm3 = Left(LTrim(wm), 3)                                                             'wm等于wm去除左侧无效字符的左前三个字符
- B5 z: X1 j/ C  K9 x    If wm3 = "GBT" Then                                                                  '当wm3等于"GBT"时
; ]! [6 c$ m  G% r# |2 ^/ M( I, @        wm4 = "GB/T" + Mid(wm2, 4)                                                       'wm4等于"GB/T"和wm2的第4个和后面的所有字符              '当零件是国标时添加国标号，文件名中/是非法字符
    Else
9 Z! r: z4 f" O9 A) q+ n$ m        wm4 = wm2                                                                         '否则wm4等wm2           '空格前面是图号
) J5 O: K5 l; n    End If

    wm5 = Mid(wm, wm1 + 2)                                                                'wm5等于wm中的第wm1+2个后面的所有字符
    wm6 = Right(wm, 7)                                                                    'wm6等于wm最后面的7个字符
9 z2 m# T9 m- f. `5 ?- i2 F    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的所有字符数
8 u8 G/ {; p- E' b' c! Q    End If
    tg5 = Left(wm5, wm7)                                                                  'tg5等于wm5左侧的wm7个字符          ,空格后面是名称，有后缀名并去掉后缀名，无后缀后（文件未保存时)直接上档

. c( O  G& h; ?5 J8 R6 {5 T  REnd If                                                                                                                       '此段为图名分离定义
5 N0 ], _7 u# l  n

If wm1 > 0 Then                                                                           '当wm1大于0时
tg4 = wm4                                                                                 'tg4等于wm4              '文件名有空格时，图号为分离出来图号
* A) ^3 s, s! G. H* f  d# k) X3 zElse
    wm8 = Right(wm, 7)                                                                    'wm8等于wm最后面的7个字符
* ^1 I* ~& k2 T9 P1 D    If wm8 = ".SLDPRT" Or wm8 = ".SLDASM" Or wm8 = ".sldprt" Or wm8 = ".sldasm" Then      '当wm8等于这4个值时
        wm9 = Len(wm) - 7                                                                 'wm9等于wm的所有字符数-7
/ V; I! }0 K$ u8 U- K0 @    Else
        wm9 = Len(wm)
* f9 F. V0 ~$ Z: ]# t  z    End If                                                                                '否则wm9等于wm所有字符数-7
- O; G  e9 a. i  u  K5 n. ltg4 = Left(wm, wm9)                                                                       'tg4等于wm左侧的wm9个字符    '文件无空格时，文件名即是图号，并去掉后缀名,无后缀名（文件未保存时)直接上档
5 g) E9 i& J2 \* ~) S* C" H$ sEnd If                                                                                                                        '此段为非图号名称命名文件，将文件名加到图号属性
1 Z: @& M$ K' u9 ^& r$ P0 H# M& a'例，fgq01-001 前门板：分离后图号（fgq-001），名称（前门板)
& Q8 U& m: h$ n: f'例，fgq01-001 前 门板：分离后图号（fgq-001 前），名称（门板)
'例，fgq01-001-前门板：分离后图号（fgq-001-前门板），名称为空
( o# u1 k1 u; i) y+ Q'以最后一个空格为准分离
9 Z% E2 ~6 p% ?

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由后向前搜索到第一个"\"字符在第几个
& d5 q8 i) i* g4 }7 X; f1 t2 mlz5 = InStr(lz3, "\")                                                                    'lz5为lz2由前向后搜索到第一个"\"字符在第几个
2 c& X6 d* U. wtg1 = 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个字符
( ]* j2 V6 P% m7 R, L! }# Z
! `' t5 l, R; k# N; Glz6 = 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
- {+ j. k% y' l1 W: ]3 Q* zEnd If                                                                                    '此段为文件路径提取项目号
* A( B* s8 g6 Y3 P* L) E5 S% ['例，零件文件完整路径为：E:\工作文档\B-非标产品\非标--F类\FGQ--定制角架\2020版\前门板.SLDPRT
% h# [1 O5 y) N' ]* H+ a) ]'由后向前搜索“--”,第一个“--”向前到“\”间为产品编号（FGQ），向后到“\”间为产品名称（定制角架），向后的第一个“\”和第二个间“\”，为版本号(2020版)。
7 e8 `$ T- k0 T) u2 c) l9 W

! t5 d% B& A: g1 C* G3 P
" M/ l& o+ [; t* p7 K# I3 DbRet = swModel2.AddCustomInfo3("", "产品编号", swCustomInfoText, tg1)
bRet = swModel2.AddCustomInfo3("", "产品名称", swCustomInfoText, tg2)
( G( B1 M; s# l$ j. ~1 ~bRet = swModel2.AddCustomInfo3("", "版本号", swCustomInfoText, tg3)
( u- h. `; }$ ebRet = swModel2.AddCustomInfo3("", "图号", swCustomInfoText, tg4)
bRet = swModel2.AddCustomInfo3("", "Description", swCustomInfoText, tg5)
bRet = swModel2.AddCustomInfo3("", "数量", swCustomInfoText, "1")
bRet = swModel2.AddCustomInfo3("", "备注1", swCustomInfoText, " ")
1 z# {! e+ o7 f& E! \' O7 ~! I9 IbRet = swModel2.AddCustomInfo3("", "备注2", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "备注3", swCustomInfoText, " ")
; P9 V/ h4 J. I. Q  B$ t1 C# Y$ CbRet = swModel2.AddCustomInfo3("", "Material", swCustomInfoText, tg6)
6 W4 V/ ^9 X5 t& V' jbRet = swModel2.AddCustomInfo3("", "SH", swCustomInfoText, tg7)
7 Q" j3 q& }3 t- s8 V# b7 `bRet = swModel2.AddCustomInfo3("", "重量", swCustomInfoText, tg8)
$ v! C8 M9 z  z4 ~bRet = swModel2.AddCustomInfo3("", "表面积", swCustomInfoText, tg9)                         '此段为填写自定义属性项与其值

+ T3 d) l% X+ N8 CDim thisFeat As SldWorks.Feature                                                         '另外增加一段宏，取读取切割清单数据，并添加到属性项。
) ]! o) H: P: P, t0 Y, VDim thisSubFeat As SldWorks.Feature
6 _: G% }5 i9 x, D* d1 k0 A+ `Dim cutFolder As Object
4 F& Q0 ]5 R8 \# B& PDim BodyCount As Integer
7 z9 e3 m" }+ l# [1 mDim custPropMgr As SldWorks.CustomPropertyManager
8 n/ J+ c( a+ [/ F; {4 D0 O7 DDim propNames As Variant
+ g9 z$ X/ D- z; |. j' n  \$ g; oDim vName As Variant
% x2 U* ]  [2 ~0 A; `5 YDim propName As String
Dim Value As String
& V: Z8 J; z9 s- kDim resolvedValue As String
Dim bjkcd As Double
) M9 t0 w7 K! SDim bjkkd As Double
'Sub main()
& h/ v5 A% T/ l* d'Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
% E( t( g% w+ K' ^0 TSet thisFeat = Part.FirstFeature
Do While Not thisFeat Is Nothing '遍历设计树
If thisFeat.GetTypeName = "SolidBodyFolder" Then
" o7 b; l9 m( I! ?) jthisFeat.GetSpecificFeature2.UpdateCutList
End If
' f8 v0 ^8 O- U2 uSet thisSubFeat = thisFeat.GetFirstSubFeature
Do While Not thisSubFeat Is Nothing
  x# y# G, V5 A/ V" r8 RIf thisSubFeat.GetTypeName = "CutListFolder" Then '查找切割清单
Set cutFolder = thisSubFeat.GetSpecificFeature2
End If
( o& B8 H7 T# EIf Not cutFolder Is Nothing Then
( D, J+ a: `7 P+ D4 e  [BodyCount = cutFolder.GetBodyCount
0 w& J4 X% p) b0 Y0 T. @% nIf BodyCount > 0 Then
Set custPropMgr = thisSubFeat.CustomPropertyManager
If Not custPropMgr Is Nothing Then
propNames = custPropMgr.GetNames '获取切割清单属性的数据全部名称并放入数组
If Not IsEmpty(propNames) Then
2 K* A9 m" ^, N6 N; T+ uFor Each vName In propNames
1 @3 t' ^, r4 l% y  SpropName = vName
custPropMgr.Get2 propName, Value, resolvedValue '获取全部属性名称 ，数值和评估的值
/ q# [  s, n$ u8 H. Y/ n+ G+ fIf propName = "边界框长度" Then bjkcd = resolvedValue '判断是否是自己所需要的数据，如果是就获取
If propName = "边界框宽度" Then bjkkd = resolvedValue
) y# t4 h* ]0 j7 J" d" y$ @% QNext vName
End If
1 |  |$ U1 e, A0 G. pEnd If
! a7 M1 V! F4 t& \4 I4 wEnd If
* a2 b) g. b7 ]0 ZEnd If
Set thisSubFeat = thisSubFeat.GetNextSubFeature
Loop
% U$ r" O) b" P5 e! w7 gSet thisFeat = thisFeat.GetNextFeature
; _1 q7 A7 b# Q, Y1 M' LLoop
: n1 d1 Q$ }, n6 s6 y'blnretval = Part.DeleteCustomInfo2("", "边界框长度") '删除属性栏上摘要信息的数据
'blnretval = Part.DeleteCustomInfo2("", "边界框宽度")
blnretval = Part.AddCustomInfo3("", "开料长度", swCustomInfoText, bjkcd) '添加数据到摘要信息
8 B7 w. p* C! x$ I0 x3 |) p! Jblnretval = Part.AddCustomInfo3("", "开料宽度", swCustomInfoText, bjkkd)
, O$ J+ J! H! W$ X+ \& q
End Sub
* l! {: D* w% x; K& B
% L8 J0 O8 G0 Y0 ]

远祥

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

晓昀

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

柴荣1917

学习一下。

tg-000057

晓昀 发表于 2021-1-13 17:17
这个是不是CAD转pdf的？佩服做软件二次开发的人。

) B/ Y. o4 R5 h# B' Bcad转PDF，用cad的PDF打印机就行了，这个是sw转dwg，dxf，和pdf等格式的。

meltemi

学习一下，