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

tg-000057

1 `! M" @" t  a+ f/ |- \8 w$ h工程图转格式:
2 u, V- E6 ]  n$ T9 L

! i" \  X9 O) g( y' pDim swApp As Object
Dim Part As Object
Dim Filename As String
Dim No As Integer
' S& @5 `: j% {7 `5 o, [" ADim Title As String          '以上设定变量
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc                                                  '以上交换数据
1 l! q' U  a1 dFilename = Part.GetPathName()                                               'Filename为文件名
No = Len(Filename)                                                          'no为工程图文件名字符串总数
1 W& P$ ]0 \3 g) O! ~6 hIf No > 0 Then                                                              '当NO大于0时（转换格式名称是工程图名称，故要先保存工程图才可转换，工程图未保存无名称，无字符串，不可进行一下步)
Filename = Left(Filename, No - 7) + "." + Right(Filename, 1)                '字串符操作，no-7为去掉工程图后缀名，"."+ right（filename,1）为增加后缀名最后一个字母作为识别，用于区别客户来图，可不要
9 y' }1 T* T* d0 g0 e& P5 gPart.SaveAs2 Filename & ".dwg", 0, True, False                              '输出需要转换的格式文件，已有文件则自动替换，不提示，（有些格式文件在打开状态中不可替换，替换不成功也不提示)
Part.SaveAs2 Filename & ".pdf", 0, True, False
End If
End Sub


5 h- y1 N* O( Y7 X( d8 A6 {
属性改写宏:


+ o& t) x  ^& \" C+ E  w& Q
+ W: a5 N. ^3 MSub main()
+ t6 N$ V6 T7 j6 d( z# |. t- C6 s+ {
3 G, E3 Q0 U' m# k1 JDim swApp As SldWorks.SldWorks
6 l% t: Z! l/ x) s2 s3 XDim swModel2 As SldWorks.ModelDoc2
Dim SelMgr As SldWorks.SelectionMgr
Dim vCustInfoNameArr2 As Variant
; {# |- [- N3 E- d8 k. k- qDim vCustInfoName2 As Variant
  l$ S$ B( h' X, _2 X% t5 HDim CurCFGname As Variant
% p7 s2 r, d) \0 KDim CurCFGnameCount As Integer
% k4 h7 R5 f3 J# G1 s2 m5 k9 Q7 zDim Vnamearr As Variant
% [1 c! e& v) ?/ B7 [. dDim CusPropMgr As CustomPropertyManager
: ], G2 J& Y9 S6 ]Dim bRet As Boolean
1 f6 Y; u" v6 h4 p1 vDim Vnamearr2 As Variant
. ~0 G5 t& [& P# D" C- s
6 J8 V7 }5 c$ L' {( PDim strmat As String
. e6 _* a5 `; j! ]1 m- C" xDim tempvalue As String
1 \3 L3 k  V+ [* P
Set swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
' c& E! K0 U- m( S3 E2 T% JSet SelMgr = swModel2.SelectionManager '

Dim tg1 As String
Dim tg2 As String
# [* C" w$ R" r# f7 k! s/ r% w, wDim tg3 As String
Dim tg4 As String
Dim tg5 As String
Dim tg6 As String
1 G2 S0 A# Q* m, r8 N2 CDim tg7 As String
Dim tg8 As String
Dim tg9 As String
Dim tg10 As String
Dim tg11 As String
! r& Y/ p5 [* F% pDim wm As String
Dim wm1 As Integer
" C/ g# K+ ~( N( \- z. r3 [+ cDim wm2 As String
" q4 g- }! o4 r; m3 mDim wm3 As String
Dim wm4 As String
Dim wm5 As String
& b  u* u& n0 s1 `Dim wm6 As String
6 X  ~6 O& m7 jDim wm7 As Integer
Dim wm8 As String
1 @# [& f& Z  R4 C; ADim wm9 As Integer
Dim lz As String
Dim lz1 As Integer
Dim lz2 As String
- I: p& W* A2 `9 `* K. QDim lz3 As String
Dim lz4 As Integer
& q. g) u. @; r4 C. }) j4 iDim lz5 As Integer
Dim lz6 As String
) i; a7 E0 @5 _9 rDim lz7 As Integer                                                                     '以上为设定变量
5 m3 Y+ d1 j, D, \0 U$ H9 }

% b/ B8 H' v( b# ]: x/ c1 ~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                                                                               '此段是删除自定属性中的所有项和其项值
. d7 B7 U4 H3 X9 [; S  Q
# i% e( K) p  i
CurCFGname = swModel2.GetConfigurationNames
CurCFGnameCount = swModel2.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
    Set CusPropMgr = swModel2.Extension.CustomPropertyManager(CurCFGname(i))
0 L# v4 L8 q2 E5 ]5 H4 N    Vnamearr = CusPropMgr.GetNames
' T" |4 V/ x2 `  h+ v    If Not IsEmpty(Vnamearr) Then
( u% o1 C& M' s, k) ~' @! H; T        For Each Vnamearr2 In Vnamearr
) G/ {/ Q* k# g; s4 M' ~! ?! t            bRet = swModel2.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
( ?! C( S' j9 \6 s: y        Next
$ {8 A8 U2 R, [0 F' t# ~    End If
( z% }7 T0 \& r0 l% D- N    Next                                                                               '此断是删除其他配置中的属性所有项和其项值
' B3 D/ Z% H' J2 u- N
2 d2 f% s0 U  e% C5 E5 t$ f( g) P
wm = swApp.ActiveDoc.GetTitle()                                                         '定义是文件名
lz = swApp.ActiveDoc.GetPathName()                                                      '定义为文件路径
5 l5 j1 p( C5 ~$ s; ctg6 = Chr(34) + Trim("SW-Material" + "@") + wm + Chr(34)                                '定义材料属性
7 e9 k, C$ a+ V2 z9 utg7 = Chr(34) + Trim("厚度" + "@") + wm + Chr(34)                                       '定义钣金厚度属性
2 ~& z3 N' o# Y; G! U! Ftg8 = Chr(34) + Trim("SW-Mass" + "@") + wm + Chr(34) + "kg"                             '定义质量属性
( i9 q3 d7 g2 E& ftg9 = Chr(34) + Trim("SW-SurfaceArea" + "@") + wm + Chr(34) + "㎡"                      '定义表面积属性
bRet = swModel2.DeleteCustomInfo2("", "图号")
0 T- Z- F* N/ s5 {8 [% TbRet = swModel2.DeleteCustomInfo2("", "Description")

3 X0 x' q( ?) g$ }9 x1 U) v0 h
wm1 = InStrRev(wm, " ") - 1                                                              '引号内为空格，为图名分离符号        '从右向左搜索到第一个" "符号为第几个字串符
4 L) R9 s2 w' eIf wm1 > 0 Then                                                                          '当mw1大于0量时
2 Y2 v1 V: z3 j* Q3 a$ `3 U    wm2 = Left(wm, wm1)                                                                  'wm2等于从wm的左侧开始提取mw1个字符
    wm3 = Left(LTrim(wm), 3)                                                             'wm等于wm去除左侧无效字符的左前三个字符
; A; o0 F0 `1 w6 d    If wm3 = "GBT" Then                                                                  '当wm3等于"GBT"时
        wm4 = "GB/T" + Mid(wm2, 4)                                                       'wm4等于"GB/T"和wm2的第4个和后面的所有字符              '当零件是国标时添加国标号，文件名中/是非法字符
    Else
4 W1 P0 h2 s1 T8 w4 I, _        wm4 = wm2                                                                         '否则wm4等wm2           '空格前面是图号
    End If
: g2 N1 J# W5 C. e
    wm5 = Mid(wm, wm1 + 2)                                                                'wm5等于wm中的第wm1+2个后面的所有字符
7 q0 M' [* _4 ?6 R2 |7 d* I    wm6 = Right(wm, 7)                                                                    'wm6等于wm最后面的7个字符
3 W) H! `7 p; s2 R    If wm6 = ".SLDPRT" Or wm6 = ".SLDASM" Or wm6 = ".sldprt" Or wm6 = ".sldasm" Then      '当wm6等于这4个值时
        wm7 = Len(wm5) - 7                                                                'wm7等于wm5的所有字符数-7
% }' y* x2 t! K; r) H: L4 m    Else
        wm7 = Len(wm5)                                                                    '否则wm7等于wm5的所有字符数
    End If
) x! v% e  m" f& |& ^/ s% j    tg5 = Left(wm5, wm7)                                                                  'tg5等于wm5左侧的wm7个字符          ,空格后面是名称，有后缀名并去掉后缀名，无后缀后（文件未保存时)直接上档
$ c' z; ?1 k. D6 Z" f
- {: _' X) T( \7 I+ f' \6 IEnd If                                                                                                                       '此段为图名分离定义
1 n2 `* ]' W0 z; x+ n. v

If wm1 > 0 Then                                                                           '当wm1大于0时
+ I! }- ^. P( R. Ftg4 = 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
) `2 ]  `1 k; J" b  e+ R    Else
        wm9 = Len(wm)
. A  e% \( N3 o+ v4 S1 {    End If                                                                                '否则wm9等于wm所有字符数-7
, j/ w1 M* L, N8 ?tg4 = Left(wm, wm9)                                                                       'tg4等于wm左侧的wm9个字符    '文件无空格时，文件名即是图号，并去掉后缀名,无后缀名（文件未保存时)直接上档
End If                                                                                                                        '此段为非图号名称命名文件，将文件名加到图号属性
'例，fgq01-001 前门板：分离后图号（fgq-001），名称（前门板)
'例，fgq01-001 前 门板：分离后图号（fgq-001 前），名称（门板)
) X: v% R# }' y2 X8 R'例，fgq01-001-前门板：分离后图号（fgq-001-前门板），名称为空
'以最后一个空格为准分离


# q7 C# ~5 A( E5 k7 L& m) glz1 = InStrRev(lz, "--")                                                                 'lz1为lz由后向前搜索到第一个"--"字符在第几个
- @, q; p& h& ]6 x5 g" I& gIf 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个)
' A2 G* \7 u7 d2 _) V8 ]tg2 = Left(lz3, lz5 - 1)                                                                 'tg2等于lz3左侧的lz5-1个字符
; H1 X: b$ \! a
lz6 = Mid(lz3, lz5 + 1)                                                                  'lz6等于lz3第lz5+1个后面的所有字符
# D4 x7 O* N' [! k, U1 H8 W9 jlz7 = InStr(lz6, "\")                                                                    'lz7为lz6由左向右搜索出第一个"\"字符在第几个
0 o0 }# B: _$ Q( G" l, V' Q. ZIf lz7 > 0 Then                                                                          '当lz7大于0时
tg3 = Left(lz6, lz7 - 1)                                                                 'tg3等于lz6左侧的lz7-1个字符
End If
End If                                                                                    '此段为文件路径提取项目号
'例，零件文件完整路径为：E:\工作文档\B-非标产品\非标--F类\FGQ--定制角架\2020版\前门板.SLDPRT
8 p% G+ v8 ]2 y/ I/ z'由后向前搜索“--”,第一个“--”向前到“\”间为产品编号（FGQ），向后到“\”间为产品名称（定制角架），向后的第一个“\”和第二个间“\”，为版本号(2020版)。
4 J3 q5 e% m( V; c& A  y/ H
. v2 t) D" \" w3 _% j
* t6 Q, {& s$ |6 R' I# N
* w. W$ o8 y! `# fbRet = swModel2.AddCustomInfo3("", "产品编号", swCustomInfoText, tg1)
bRet = swModel2.AddCustomInfo3("", "产品名称", swCustomInfoText, tg2)
; c, F9 q6 \" ~6 d7 @% obRet = swModel2.AddCustomInfo3("", "版本号", swCustomInfoText, tg3)
) ]! ~/ n/ r" C! o, C. JbRet = swModel2.AddCustomInfo3("", "图号", swCustomInfoText, tg4)
bRet = swModel2.AddCustomInfo3("", "Description", swCustomInfoText, tg5)
bRet = swModel2.AddCustomInfo3("", "数量", swCustomInfoText, "1")
% d+ V5 d) e2 R! `9 zbRet = swModel2.AddCustomInfo3("", "备注1", swCustomInfoText, " ")
& _6 B: n( t' RbRet = swModel2.AddCustomInfo3("", "备注2", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "备注3", swCustomInfoText, " ")
& I2 `# W" s- X) j9 F& ^bRet = swModel2.AddCustomInfo3("", "Material", swCustomInfoText, tg6)
bRet = swModel2.AddCustomInfo3("", "SH", swCustomInfoText, tg7)
bRet = swModel2.AddCustomInfo3("", "重量", swCustomInfoText, tg8)
bRet = swModel2.AddCustomInfo3("", "表面积", swCustomInfoText, tg9)                         '此段为填写自定义属性项与其值
* U- M9 r1 v( q7 A% z6 l3 U  D
9 `' ], [1 j3 W# HDim thisFeat As SldWorks.Feature                                                         '另外增加一段宏，取读取切割清单数据，并添加到属性项。
8 E" ~% ?; A! N- k/ S0 ^Dim thisSubFeat As SldWorks.Feature
Dim cutFolder As Object
% B+ M0 I! n( P2 lDim BodyCount As Integer
Dim custPropMgr As SldWorks.CustomPropertyManager
; M/ A5 c6 t6 U- y* s1 f$ {2 VDim propNames As Variant
4 n' F: X+ n2 A9 b3 ]2 FDim vName As Variant
Dim propName As String
Dim Value As String
& t1 W* Y1 O, }* NDim resolvedValue As String
1 w# Y; T8 l1 R/ EDim bjkcd As Double
Dim bjkkd As Double
: `3 K& W( p! P4 H0 W' G4 b; R' z'Sub main()
; j! S' J' `: G9 M: E9 H6 i5 S8 n'Set swApp = Application.SldWorks
$ ?8 e( _8 |# N- u6 W$ FSet Part = swApp.ActiveDoc
Set thisFeat = Part.FirstFeature
Do While Not thisFeat Is Nothing '遍历设计树
If thisFeat.GetTypeName = "SolidBodyFolder" Then
- Y9 ~7 A" ]' ~0 M7 ~! R. n4 h! lthisFeat.GetSpecificFeature2.UpdateCutList
End If
Set thisSubFeat = thisFeat.GetFirstSubFeature
; Y4 Y, r9 f; w: }# k4 e1 FDo 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
2 b' n& K: D8 z- GIf BodyCount > 0 Then
Set custPropMgr = thisSubFeat.CustomPropertyManager
. K* r1 z" I7 W, E* B$ G7 AIf Not custPropMgr Is Nothing Then
- d0 v3 \' q$ S& D6 HpropNames = custPropMgr.GetNames '获取切割清单属性的数据全部名称并放入数组
If Not IsEmpty(propNames) Then
9 ?8 V1 P$ V$ J3 F8 gFor Each vName In propNames
propName = vName
; ~; t0 z! `3 f$ w! _9 C' N" E& FcustPropMgr.Get2 propName, Value, resolvedValue '获取全部属性名称 ，数值和评估的值
( S5 Z; A; a3 M( n- \If propName = "边界框长度" Then bjkcd = resolvedValue '判断是否是自己所需要的数据，如果是就获取
  V2 j! i- i) F4 Z4 d* c: ^2 W2 GIf propName = "边界框宽度" Then bjkkd = resolvedValue
6 Y4 H' N# b: t8 }1 hNext vName
End If
End If
End If
9 q0 O& X0 C8 qEnd If
Set thisSubFeat = thisSubFeat.GetNextSubFeature
/ y+ h* l+ \  o1 o. `Loop
Set thisFeat = thisFeat.GetNextFeature
' B' `6 M0 \, i5 bLoop
'blnretval = Part.DeleteCustomInfo2("", "边界框长度") '删除属性栏上摘要信息的数据
; D: ]( z9 F( o3 E2 X' U/ b# w' J% l'blnretval = Part.DeleteCustomInfo2("", "边界框宽度")
blnretval = Part.AddCustomInfo3("", "开料长度", swCustomInfoText, bjkcd) '添加数据到摘要信息
) `) y; L% {5 u4 E1 Hblnretval = Part.AddCustomInfo3("", "开料宽度", swCustomInfoText, bjkkd)

End Sub

/ a! W! R, b. G7 S

远祥

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

晓昀

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

柴荣1917

学习一下。

tg-000057

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

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