分享兩個宏，有詳細(xì)注解，可盡情修改使用，代碼也一起放了。

tg-000057

$ G% c/ ~, n+ O: r2 E6 g工程圖轉(zhuǎn)格式:

: K  H- q, G7 O% }% M6 |8 c2 y
( q3 l) c+ ?) f( v# V& LDim swApp As Object
2 j6 h' C4 D7 YDim Part As Object
Dim Filename As String
# f1 Y0 ^0 j  K$ [# [3 {$ `Dim No As Integer
Dim Title As String          '以上設(shè)定變量
Sub main()
8 U9 ]* L# A8 Q9 w  }Set swApp = Application.SldWorks
* ?& o' T: l& V2 v/ m: FSet Part = swApp.ActiveDoc                                                  '以上交換數(shù)據(jù)
" S) @8 P; O$ b  K7 ^Filename = Part.GetPathName()                                               'Filename為文件名
No = Len(Filename)                                                          'no為工程圖文件名字符串總數(shù)
If No > 0 Then                                                              '當(dāng)NO大于0時（轉(zhuǎn)換格式名稱是工程圖名稱，故要先保存工程圖才可轉(zhuǎn)換，工程圖未保存無名稱，無字符串，不可進(jìn)行一下步)
; v: a4 C6 y# a3 R# rFilename = Left(Filename, No - 7) + "." + Right(Filename, 1)                '字串符操作，no-7為去掉工程圖后綴名，"."+ right（filename,1）為增加后綴名最后一個字母作為識別，用于區(qū)別客戶來圖，可不要
+ c3 u- s8 a: ^Part.SaveAs2 Filename & ".dwg", 0, True, False                              '輸出需要轉(zhuǎn)換的格式文件，已有文件則自動替換，不提示，（有些格式文件在打開狀態(tài)中不可替換，替換不成功也不提示)
Part.SaveAs2 Filename & ".pdf", 0, True, False
End If
+ `/ D! j# c3 f, Z5 PEnd Sub

  r8 h9 p; v/ F0 u3 i' j. I

9 `) x7 D) T1 o1 g! P屬性改寫宏:

! c2 S$ i# t0 a0 d" g7 K7 w

- c( H: d4 C! S7 TSub main()
3 A% t+ a2 W0 J- @
Dim swApp As SldWorks.SldWorks
Dim swModel2 As SldWorks.ModelDoc2
, b4 q* L4 N5 g6 _% `2 \5 f, q8 JDim SelMgr As SldWorks.SelectionMgr
) p: V8 |+ C; {! V3 u0 T  N2 u8 {6 C9 IDim vCustInfoNameArr2 As Variant
3 S5 G* @5 H' {7 P' ^, G1 J- CDim vCustInfoName2 As Variant
, |9 i4 s/ `, ^, oDim CurCFGname As Variant
9 I$ r5 |9 y$ k, i7 u. _6 i/ H% e$ K/ TDim CurCFGnameCount As Integer
Dim Vnamearr As Variant
0 ^; h8 I: r- S3 [4 j  xDim CusPropMgr As CustomPropertyManager
Dim bRet As Boolean
Dim Vnamearr2 As Variant

  k7 T/ Z, ~  ~6 P6 C/ n& f5 oDim strmat As String
3 i- G7 V$ E  L/ SDim tempvalue As String

Set swApp = Application.SldWorks
! w, ]% ^. W+ I" L! m) l  eSet swModel2 = swApp.ActiveDoc
/ w: H7 Q" f* R2 R+ n. |Set SelMgr = swModel2.SelectionManager '

Dim tg1 As String
: H- z* p. z  b1 J! |Dim tg2 As String
Dim tg3 As String
Dim tg4 As String
  j3 i9 X' X5 Y  X" QDim tg5 As String
( _, P. m( U- e# x2 U7 vDim tg6 As String
Dim tg7 As String
1 T+ Y! Q5 ~& y8 `Dim tg8 As String
Dim tg9 As String
4 R) q2 |5 Y- aDim tg10 As String
  E$ w) B8 m& v" `9 R3 WDim tg11 As String
Dim wm As String
- }; \! b7 U6 dDim wm1 As Integer
; p  J& t3 g0 ^1 I: \" f% {: O" N- M, mDim wm2 As String
  N/ A# I& {- y/ O6 f0 sDim wm3 As String
* L! n5 J7 n* pDim wm4 As String
; c9 ~$ ~6 m* R7 R* z' yDim wm5 As String
4 I* f2 D  G; X- \Dim wm6 As String
Dim wm7 As Integer
% x( e! C3 Y1 p$ b: @9 |Dim wm8 As String
1 {1 i7 V$ R# C9 p" j: aDim wm9 As Integer
Dim lz As String
. s- h3 R, o  o* M, d/ ]Dim lz1 As Integer
; g/ r7 U, O4 A" l+ G6 UDim lz2 As String
, j9 V2 t5 C$ A  `  ?Dim lz3 As String
Dim lz4 As Integer
! R9 k% `3 ]0 r; |Dim lz5 As Integer
Dim lz6 As String
Dim lz7 As Integer                                                                     '以上為設(shè)定變量


swApp.ActiveDoc.ActiveView.FrameState = 1
vCustInfoNameArr2 = swModel2.GetCustomInfoNames
: c# ~0 A2 p/ s) S* U  If Not IsEmpty(vCustInfoNameArr2) Then
     For Each vCustInfoName2 In vCustInfoNameArr2
8 n6 I) D  \; x2 [         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
0 U* t& v: k6 P1 N3 h  s      Next
, f$ Q9 A% Q4 s# ~% ~  t  End If                                                                               '此段是刪除自定屬性中的所有項和其項值
% w' r. i, u9 ^" ]
- _/ Q# g- I* y: i' H2 D% S0 \
CurCFGname = swModel2.GetConfigurationNames
CurCFGnameCount = swModel2.GetConfigurationCount
For i = 0 To CurCFGnameCount - 1
, P" X5 W, ?- ]: u+ B    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                                                                               '此斷是刪除其他配置中的屬性所有項和其項值
8 Z& t. N7 R( D8 u

wm = swApp.ActiveDoc.GetTitle()                                                         '定義是文件名
& h  @5 J2 M- p, c, plz = swApp.ActiveDoc.GetPathName()                                                      '定義為文件路徑
tg6 = Chr(34) + Trim("SW-Material" + "@") + wm + Chr(34)                                '定義材料屬性
tg7 = Chr(34) + Trim("厚度" + "@") + wm + Chr(34)                                       '定義鈑金厚度屬性
- b# {# [4 Q2 i  d1 Y$ Qtg8 = Chr(34) + Trim("SW-Mass" + "@") + wm + Chr(34) + "kg"                             '定義質(zhì)量屬性
tg9 = Chr(34) + Trim("SW-SurfaceArea" + "@") + wm + Chr(34) + "㎡"                      '定義表面積屬性
& }% y7 w2 v: p" {3 qbRet = swModel2.DeleteCustomInfo2("", "圖號")
  b0 p4 q9 q7 \3 q9 _( FbRet = swModel2.DeleteCustomInfo2("", "Description")


) e. h; R9 F6 a. N6 Swm1 = InStrRev(wm, " ") - 1                                                              '引號內(nèi)為空格，為圖名分離符號        '從右向左搜索到第一個" "符號為第幾個字串符
+ E! I, w7 J* d# ]9 OIf wm1 > 0 Then                                                                          '當(dāng)mw1大于0量時
, g& b4 x) Y2 n! ~9 ]8 Y' T    wm2 = Left(wm, wm1)                                                                  'wm2等于從wm的左側(cè)開始提取mw1個字符
# m0 U: ^7 H4 |, y8 q4 J    wm3 = Left(LTrim(wm), 3)                                                             'wm等于wm去除左側(cè)無效字符的左前三個字符
    If wm3 = "GBT" Then                                                                  '當(dāng)wm3等于"GBT"時
        wm4 = "GB/T" + Mid(wm2, 4)                                                       'wm4等于"GB/T"和wm2的第4個和后面的所有字符              '當(dāng)零件是國標(biāo)時添加國標(biāo)號，文件名中/是非法字符
    Else
        wm4 = wm2                                                                         '否則wm4等wm2           '空格前面是圖號
; }/ ^$ ?" y9 C* M% G    End If

    wm5 = Mid(wm, wm1 + 2)                                                                'wm5等于wm中的第wm1+2個后面的所有字符
7 K" V: N% W$ e# z. o    wm6 = Right(wm, 7)                                                                    'wm6等于wm最后面的7個字符
    If wm6 = ".SLDPRT" Or wm6 = ".SLDASM" Or wm6 = ".sldprt" Or wm6 = ".sldasm" Then      '當(dāng)wm6等于這4個值時
! t7 D5 p" F) j: _4 q& K; S        wm7 = Len(wm5) - 7                                                                'wm7等于wm5的所有字符數(shù)-7
/ D" `: b& ^  N  x7 L3 Z    Else
* r; H) m" W; t# e! s$ q. L        wm7 = Len(wm5)                                                                    '否則wm7等于wm5的所有字符數(shù)
    End If
$ ^! Q! K1 `8 a; G1 f  f1 R+ C& S    tg5 = Left(wm5, wm7)                                                                  'tg5等于wm5左側(cè)的wm7個字符          ,空格后面是名稱，有后綴名并去掉后綴名，無后綴后（文件未保存時)直接上檔

End If                                                                                                                       '此段為圖名分離定義

# O7 ~% M$ h) u# i
' a1 X7 B- w4 S/ |- n: O0 }If wm1 > 0 Then                                                                           '當(dāng)wm1大于0時
. M5 J: E! |5 e, s: d* ytg4 = wm4                                                                                 'tg4等于wm4              '文件名有空格時，圖號為分離出來圖號
$ x5 D4 M& F- z' |" e' ~Else
    wm8 = Right(wm, 7)                                                                    'wm8等于wm最后面的7個字符
2 `! c& p; f& F2 [) O    If wm8 = ".SLDPRT" Or wm8 = ".SLDASM" Or wm8 = ".sldprt" Or wm8 = ".sldasm" Then      '當(dāng)wm8等于這4個值時
        wm9 = Len(wm) - 7                                                                 'wm9等于wm的所有字符數(shù)-7
; d( A# r* `4 }    Else
: i' t  e( R; x: F( H        wm9 = Len(wm)
    End If                                                                                '否則wm9等于wm所有字符數(shù)-7
tg4 = Left(wm, wm9)                                                                       'tg4等于wm左側(cè)的wm9個字符    '文件無空格時，文件名即是圖號，并去掉后綴名,無后綴名（文件未保存時)直接上檔
5 Z$ ]4 k) I3 I6 Y8 x) s* bEnd If                                                                                                                        '此段為非圖號名稱命名文件，將文件名加到圖號屬性
% h) t) E! _, [  K'例，fgq01-001 前門板：分離后圖號（fgq-001），名稱（前門板)
'例，fgq01-001 前 門板：分離后圖號（fgq-001 前），名稱（門板)
! d6 e) y/ T- U# Y5 J'例，fgq01-001-前門板：分離后圖號（fgq-001-前門板），名稱為空
: B0 w& Q" c+ N' ^7 H) R( b'以最后一個空格為準(zhǔn)分離
  I- r$ E% k6 c3 d- G
) {2 l7 p: B# x$ o+ b- ^
$ ^% |) o, I5 C1 p+ Blz1 = InStrRev(lz, "--")                                                                 'lz1為lz由后向前搜索到第一個"--"字符在第幾個
1 }) Y% d5 b; h% v& D4 n4 b  LIf lz1 > 0 Then                                                                          '當(dāng)lz1大于0時
lz2 = Mid(lz, lz1 - 8, 8)                                                                'lz2等于lz的第lz1-8個和其后面8個字符
! p5 I' S# L6 d) E' jlz3 = Mid(lz, lz1 + 2)                                                                   'lz3等于lz的第lz2+2個后其后面所有字符
; o/ F" \' K) f" v/ i7 p! Slz4 = InStrRev(lz2, "\")                                                                 'lz4為lz2由后向前搜索到第一個"\"字符在第幾個
lz5 = InStr(lz3, "\")                                                                    'lz5為lz2由前向后搜索到第一個"\"字符在第幾個
# r4 a9 N+ H; Q9 atg1 = Mid(lz2, lz4 + 1)                                                                  'tg1等于lz2的第lz4+1個后面的所有字符
" Y8 }! L2 N- x, Q'tg1 = Right(lz2, 8 - lz4)                                                               'tg1等于lz2右側(cè)的8-lz4個字符(lz2總字符為8個)
! A! C0 U6 D5 ]/ `6 h" l- ~tg2 = Left(lz3, lz5 - 1)                                                                 'tg2等于lz3左側(cè)的lz5-1個字符
! g* X" R  N3 c. }
+ b8 t4 W8 u" flz6 = Mid(lz3, lz5 + 1)                                                                  'lz6等于lz3第lz5+1個后面的所有字符
' J& g- ~2 \5 W; P+ N. [lz7 = InStr(lz6, "\")                                                                    'lz7為lz6由左向右搜索出第一個"\"字符在第幾個
0 u' M" q8 i' I- b2 WIf lz7 > 0 Then                                                                          '當(dāng)lz7大于0時
& \/ k% b; D1 v8 @: z/ t, Utg3 = Left(lz6, lz7 - 1)                                                                 'tg3等于lz6左側(cè)的lz7-1個字符
End If
End If                                                                                    '此段為文件路徑提取項目號
'例，零件文件完整路徑為：E:\工作文檔\B-非標(biāo)產(chǎn)品\非標(biāo)--F類\FGQ--定制角架\2020版\前門板.SLDPRT
'由后向前搜索“--”,第一個“--”向前到“\”間為產(chǎn)品編號（FGQ），向后到“\”間為產(chǎn)品名稱（定制角架），向后的第一個“\”和第二個間“\”，為版本號(2020版)。

1 y* b( a; Q" ~( z' D9 e

1 P/ ]3 Z6 [" L7 b8 ?6 nbRet = swModel2.AddCustomInfo3("", "產(chǎn)品編號", swCustomInfoText, tg1)
bRet = swModel2.AddCustomInfo3("", "產(chǎn)品名稱", swCustomInfoText, tg2)
bRet = swModel2.AddCustomInfo3("", "版本號", swCustomInfoText, tg3)
bRet = swModel2.AddCustomInfo3("", "圖號", swCustomInfoText, tg4)
4 J( H5 t7 @  \9 nbRet = swModel2.AddCustomInfo3("", "Description", swCustomInfoText, tg5)
bRet = swModel2.AddCustomInfo3("", "數(shù)量", swCustomInfoText, "1")
4 W9 ^% @' C$ ?" H6 wbRet = swModel2.AddCustomInfo3("", "備注1", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "備注2", swCustomInfoText, " ")
3 L% F3 ~) D( z" c! mbRet = swModel2.AddCustomInfo3("", "備注3", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "Material", swCustomInfoText, tg6)
bRet = swModel2.AddCustomInfo3("", "SH", swCustomInfoText, tg7)
bRet = swModel2.AddCustomInfo3("", "重量", swCustomInfoText, tg8)
4 _- I& o# E6 SbRet = swModel2.AddCustomInfo3("", "表面積", swCustomInfoText, tg9)                         '此段為填寫自定義屬性項與其值
' T1 t( n5 e$ D
Dim thisFeat As SldWorks.Feature                                                         '另外增加一段宏，取讀取切割清單數(shù)據(jù)，并添加到屬性項。
. y5 _; z5 L( T& ]4 y1 GDim thisSubFeat As SldWorks.Feature
Dim cutFolder As Object
Dim BodyCount As Integer
5 T! v2 \3 u- C0 NDim custPropMgr As SldWorks.CustomPropertyManager
: t0 z, [! p! ?( Y  `; E# T, kDim propNames As Variant
5 S, p) C) [  |" a. y. z- R/ U8 YDim vName As Variant
Dim propName As String
Dim Value As String
8 K8 F9 o5 y4 ~) X* k4 Y& a0 YDim resolvedValue As String
Dim bjkcd As Double
Dim bjkkd As Double
'Sub main()
'Set swApp = Application.SldWorks
) S! T0 u& Z' t$ DSet Part = swApp.ActiveDoc
Set thisFeat = Part.FirstFeature
% m" I7 I1 l1 k/ t1 w. WDo While Not thisFeat Is Nothing '遍歷設(shè)計樹
5 b" w/ i. u) B# A' S# Z" bIf thisFeat.GetTypeName = "SolidBodyFolder" Then
5 A* T$ U) \  F0 |  _thisFeat.GetSpecificFeature2.UpdateCutList
End If
/ u& v9 E- K9 [5 `0 L3 YSet thisSubFeat = thisFeat.GetFirstSubFeature
Do While Not thisSubFeat Is Nothing
) |, B: k" g+ B$ o; j$ C+ |1 ^/ PIf thisSubFeat.GetTypeName = "CutListFolder" Then '查找切割清單
' ]% C: S; |" N0 _Set cutFolder = thisSubFeat.GetSpecificFeature2
2 T8 m7 ?5 N) ^! r( BEnd If
, s: Q! y- t1 V/ I+ B$ zIf Not cutFolder Is Nothing Then
BodyCount = cutFolder.GetBodyCount
4 s  T. Q4 q, A1 h- V, O9 h3 uIf BodyCount > 0 Then
" B5 a4 B5 l: N# b  TSet custPropMgr = thisSubFeat.CustomPropertyManager
If Not custPropMgr Is Nothing Then
propNames = custPropMgr.GetNames '獲取切割清單屬性的數(shù)據(jù)全部名稱并放入數(shù)組
If Not IsEmpty(propNames) Then
For Each vName In propNames
0 O5 G' s' L) I8 l. k8 j. R4 npropName = vName
custPropMgr.Get2 propName, Value, resolvedValue '獲取全部屬性名稱 ，數(shù)值和評估的值
If propName = "邊界框長度" Then bjkcd = resolvedValue '判斷是否是自己所需要的數(shù)據(jù)，如果是就獲取
9 m" t2 r0 d. L  T+ y" |# v( TIf propName = "邊界框?qū)挾?quot; Then bjkkd = resolvedValue
Next vName
3 c% m' [* U7 SEnd If
End If
End If
End If
& Z$ ?. A- `! h: _4 VSet thisSubFeat = thisSubFeat.GetNextSubFeature
Loop
Set thisFeat = thisFeat.GetNextFeature
4 a* ^% N2 G" R; ZLoop
'blnretval = Part.DeleteCustomInfo2("", "邊界框長度") '刪除屬性欄上摘要信息的數(shù)據(jù)
2 o6 l  }! K" Y: u' o6 J0 P'blnretval = Part.DeleteCustomInfo2("", "邊界框?qū)挾?quot;)
  i$ M7 v6 w' y1 f9 v! P0 qblnretval = Part.AddCustomInfo3("", "開料長度", swCustomInfoText, bjkcd) '添加數(shù)據(jù)到摘要信息
, |+ G* c. L7 E/ ]8 g  Pblnretval = Part.AddCustomInfo3("", "開料寬度", swCustomInfoText, bjkkd)
3 A# q. z$ F* X) {( ]" Q
/ d! G/ D, G- EEnd Sub
5 p% H1 h/ z- y- Q7 ~3 V" t
- y. e8 G% i5 o/ ~% T# c% a& j& U

遠(yuǎn)祥

挺復(fù)雜啊，比較難用吧？？

曉昀

這個是不是CAD轉(zhuǎn)pdf的？佩服做軟件二次開發(fā)的人。

柴榮1917

學(xué)習(xí)一下。

tg-000057

曉昀 發(fā)表于 2021-1-13 17:17
這個是不是CAD轉(zhuǎn)pdf的？佩服做軟件二次開發(fā)的人。

cad轉(zhuǎn)PDF，用cad的PDF打印機(jī)就行了，這個是sw轉(zhuǎn)dwg，dxf，和pdf等格式的。

meltemi

學(xué)習(xí)一下，