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

tg-000057

工程圖轉(zhuǎn)格式:
. W9 b) J$ O' \5 [5 y5 c+ _. D4 y9 Q; n+ `
$ T6 b* l% J1 X: C# P* H& T2 c
Dim swApp As Object
, U# X- ~) x2 _3 rDim Part As Object
# o7 D+ n  H, l7 oDim Filename As String
Dim No As Integer
6 o/ u6 V' B, P" F5 sDim Title As String          '以上設(shè)定變量
& j) o% E% ]' P7 b4 YSub main()
0 F, |1 |. |) CSet swApp = Application.SldWorks
9 J( h1 ]! _& d# jSet Part = swApp.ActiveDoc                                                  '以上交換數(shù)據(jù)
. i- i  I6 A3 c2 w1 r. x! jFilename = Part.GetPathName()                                               'Filename為文件名
No = Len(Filename)                                                          'no為工程圖文件名字符串總數(shù)
: T( I4 I0 E0 m: c6 SIf No > 0 Then                                                              '當(dāng)NO大于0時（轉(zhuǎn)換格式名稱是工程圖名稱，故要先保存工程圖才可轉(zhuǎn)換，工程圖未保存無名稱，無字符串，不可進(jìn)行一下步)
, e- R' |7 U) P3 wFilename = Left(Filename, No - 7) + "." + Right(Filename, 1)                '字串符操作，no-7為去掉工程圖后綴名，"."+ right（filename,1）為增加后綴名最后一個字母作為識別，用于區(qū)別客戶來圖，可不要
Part.SaveAs2 Filename & ".dwg", 0, True, False                              '輸出需要轉(zhuǎn)換的格式文件，已有文件則自動替換，不提示，（有些格式文件在打開狀態(tài)中不可替換，替換不成功也不提示)
Part.SaveAs2 Filename & ".pdf", 0, True, False
End If
End Sub

7 C5 p1 J' h. L$ {! T

" P1 s8 ]8 [" |! a! l屬性改寫宏:

" N$ a! Z: w4 [) y
8 v9 U0 h$ a, h& q9 o
Sub main()

Dim swApp As SldWorks.SldWorks
- E, c- J% P; G2 x" Y, CDim swModel2 As SldWorks.ModelDoc2
Dim SelMgr As SldWorks.SelectionMgr
9 |" D% T$ _' ?' [' f8 Y/ f% i$ A- ]7 o8 MDim vCustInfoNameArr2 As Variant
7 v+ ]+ `- @! E/ Q7 a# DDim vCustInfoName2 As Variant
Dim CurCFGname As Variant
4 }2 w' {+ ~% ?; V. lDim CurCFGnameCount As Integer
; Y. U2 B& N' x; k/ a/ wDim Vnamearr As Variant
  P; W+ E  r* d! c* q# F$ [+ tDim CusPropMgr As CustomPropertyManager
Dim bRet As Boolean
6 ~, L1 l9 C0 e7 Q8 PDim Vnamearr2 As Variant

Dim strmat As String
/ ?3 D9 A5 _0 ~6 C  e! e& |1 zDim tempvalue As String
7 D( V1 N/ F$ d% `
" `& m& ~3 M: A) P  PSet swApp = Application.SldWorks
Set swModel2 = swApp.ActiveDoc
Set SelMgr = swModel2.SelectionManager '

$ l4 U- ]4 M  n! t1 m& MDim tg1 As String
' r# Z: G. H) v& X, w/ L* a  @) yDim tg2 As String
Dim tg3 As String
Dim tg4 As String
- T" j" _% k. h# W0 zDim tg5 As String
7 d/ B6 |+ Y7 E2 i, ]# A9 x  D# HDim tg6 As String
Dim tg7 As String
5 _. {4 D4 U% I! k% [, wDim tg8 As String
$ D* p2 [) T! c: o% g# S* tDim tg9 As String
Dim tg10 As String
Dim tg11 As String
Dim wm As String
2 I! {1 D4 ^5 UDim wm1 As Integer
  Y' m1 f7 p5 s5 oDim wm2 As String
Dim wm3 As String
. W$ Z" B' |/ @- _4 d& PDim wm4 As String
* \7 k% w7 K& a6 WDim wm5 As String
Dim wm6 As String
Dim wm7 As Integer
5 \% I3 c" W* m. V! d$ vDim wm8 As String
8 G3 F4 I" \6 n7 B, w. J! q! {0 c/ I4 dDim wm9 As Integer
" \! L  e  r; c" L. c) {Dim lz As String
Dim lz1 As Integer
Dim lz2 As String
+ T: g) a3 u/ L2 NDim lz3 As String
, q' |0 r( N! i+ iDim lz4 As Integer
( ?8 B7 Q' O  DDim lz5 As Integer
Dim lz6 As String
Dim lz7 As Integer                                                                     '以上為設(shè)定變量
; {! ]; ?- Y: X( b& X* N

swApp.ActiveDoc.ActiveView.FrameState = 1
. W# d0 O. G  Y' U* J0 nvCustInfoNameArr2 = swModel2.GetCustomInfoNames
( m. x2 ?# U, u! P0 {  If Not IsEmpty(vCustInfoNameArr2) Then
     For Each vCustInfoName2 In vCustInfoNameArr2
7 V( c+ `% B- E" u5 A% E! d5 a3 v         bRet = swModel2.DeleteCustomInfo(vCustInfoName2)
* D& Q* r: L& D4 N" M      Next
  End If                                                                               '此段是刪除自定屬性中的所有項和其項值

: G; X/ R) O& \$ s. Y
CurCFGname = swModel2.GetConfigurationNames
CurCFGnameCount = swModel2.GetConfigurationCount
# g) a0 D) y- u( R; rFor i = 0 To CurCFGnameCount - 1
- `3 p' G4 e# m    Set CusPropMgr = swModel2.Extension.CustomPropertyManager(CurCFGname(i))
    Vnamearr = CusPropMgr.GetNames
/ v8 X7 {2 ]" B) g( w    If Not IsEmpty(Vnamearr) Then
3 w5 U3 C: d4 a5 ?, D/ \; p        For Each Vnamearr2 In Vnamearr
            bRet = swModel2.DeleteCustomInfo2(CurCFGname(i), Vnamearr2)
% p% B6 G& l5 g- E        Next
  ?; ^* k0 P1 f    End If
) N- I. j* P3 P! _# D4 t  U4 J# n    Next                                                                               '此斷是刪除其他配置中的屬性所有項和其項值
" B: Z; Z% D$ p+ q  J- C
4 K. a- K1 D9 n2 ~' r( X' h9 T  ~
wm = swApp.ActiveDoc.GetTitle()                                                         '定義是文件名
3 P: J4 l- Y8 _! Llz = swApp.ActiveDoc.GetPathName()                                                      '定義為文件路徑
' [/ o& R: c% F, n/ O: Dtg6 = Chr(34) + Trim("SW-Material" + "@") + wm + Chr(34)                                '定義材料屬性
2 n5 l8 D" w) J+ }3 U: Ttg7 = Chr(34) + Trim("厚度" + "@") + wm + Chr(34)                                       '定義鈑金厚度屬性
tg8 = Chr(34) + Trim("SW-Mass" + "@") + wm + Chr(34) + "kg"                             '定義質(zhì)量屬性
% b1 ^: y% t6 g/ S& ntg9 = Chr(34) + Trim("SW-SurfaceArea" + "@") + wm + Chr(34) + "㎡"                      '定義表面積屬性
bRet = swModel2.DeleteCustomInfo2("", "圖號")
bRet = swModel2.DeleteCustomInfo2("", "Description")
2 d3 n1 \$ j( z2 p% y1 k6 r

wm1 = InStrRev(wm, " ") - 1                                                              '引號內(nèi)為空格，為圖名分離符號        '從右向左搜索到第一個" "符號為第幾個字串符
# S5 k5 D! V2 J7 L+ ~If wm1 > 0 Then                                                                          '當(dāng)mw1大于0量時
# v% i- q% a2 k; d* {    wm2 = Left(wm, wm1)                                                                  'wm2等于從wm的左側(cè)開始提取mw1個字符
    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           '空格前面是圖號
- h6 t5 ~" A$ L: z, z2 Z+ z    End If
# A2 x) Y9 u8 }2 c2 `9 u0 z
$ R& ]) }/ w1 A. h    wm5 = Mid(wm, wm1 + 2)                                                                'wm5等于wm中的第wm1+2個后面的所有字符
) y8 L9 o0 N% _' f2 B    wm6 = Right(wm, 7)                                                                    'wm6等于wm最后面的7個字符
, x' ~7 G4 {1 s- Y! V( r    If wm6 = ".SLDPRT" Or wm6 = ".SLDASM" Or wm6 = ".sldprt" Or wm6 = ".sldasm" Then      '當(dāng)wm6等于這4個值時
        wm7 = Len(wm5) - 7                                                                'wm7等于wm5的所有字符數(shù)-7
& e" C3 y+ D$ Z( B8 o) H; A. N/ N) O    Else
7 c6 u! [: q9 ?( I( n- }  t6 [" Z        wm7 = Len(wm5)                                                                    '否則wm7等于wm5的所有字符數(shù)
    End If
" H' t# A2 s3 F    tg5 = Left(wm5, wm7)                                                                  'tg5等于wm5左側(cè)的wm7個字符          ,空格后面是名稱，有后綴名并去掉后綴名，無后綴后（文件未保存時)直接上檔

1 l* [; e9 ?' g' R  m1 @End If                                                                                                                       '此段為圖名分離定義
  e! @4 y( d# G9 H6 j5 I

7 a1 l4 h8 u7 t& y! E" j- vIf wm1 > 0 Then                                                                           '當(dāng)wm1大于0時
tg4 = wm4                                                                                 'tg4等于wm4              '文件名有空格時，圖號為分離出來圖號
" Z6 Q- f& ?) J/ M+ _# t" bElse
    wm8 = Right(wm, 7)                                                                    'wm8等于wm最后面的7個字符
    If wm8 = ".SLDPRT" Or wm8 = ".SLDASM" Or wm8 = ".sldprt" Or wm8 = ".sldasm" Then      '當(dāng)wm8等于這4個值時
8 S% g6 m! m' R# d        wm9 = Len(wm) - 7                                                                 'wm9等于wm的所有字符數(shù)-7
2 {$ w  ?! l+ ^6 A    Else
4 U3 A# a5 c% Z) w# o6 ^- ~3 r        wm9 = Len(wm)
7 \% t( w  v) x6 T2 T- v& K# z    End If                                                                                '否則wm9等于wm所有字符數(shù)-7
* n% ~  @4 [( |tg4 = Left(wm, wm9)                                                                       'tg4等于wm左側(cè)的wm9個字符    '文件無空格時，文件名即是圖號，并去掉后綴名,無后綴名（文件未保存時)直接上檔
End If                                                                                                                        '此段為非圖號名稱命名文件，將文件名加到圖號屬性
5 B" ?. j: u7 y- H'例，fgq01-001 前門板：分離后圖號（fgq-001），名稱（前門板)
'例，fgq01-001 前 門板：分離后圖號（fgq-001 前），名稱（門板)
1 e4 R* A4 e# }: \, c'例，fgq01-001-前門板：分離后圖號（fgq-001-前門板），名稱為空
( Z, [7 g, v" L. Y/ i0 R'以最后一個空格為準(zhǔn)分離
6 g% s  M4 d5 Y6 k% ]  f$ [/ g# [) e

lz1 = InStrRev(lz, "--")                                                                 'lz1為lz由后向前搜索到第一個"--"字符在第幾個
If lz1 > 0 Then                                                                          '當(dāng)lz1大于0時
lz2 = Mid(lz, lz1 - 8, 8)                                                                'lz2等于lz的第lz1-8個和其后面8個字符
" a  I1 `4 l) J6 ?8 r2 Alz3 = Mid(lz, lz1 + 2)                                                                   'lz3等于lz的第lz2+2個后其后面所有字符
lz4 = InStrRev(lz2, "\")                                                                 'lz4為lz2由后向前搜索到第一個"\"字符在第幾個
/ x, r3 B" S& |# x) m4 Dlz5 = InStr(lz3, "\")                                                                    'lz5為lz2由前向后搜索到第一個"\"字符在第幾個
tg1 = Mid(lz2, lz4 + 1)                                                                  'tg1等于lz2的第lz4+1個后面的所有字符
6 K7 v" G$ i9 i$ O1 B3 {* @. l'tg1 = Right(lz2, 8 - lz4)                                                               'tg1等于lz2右側(cè)的8-lz4個字符(lz2總字符為8個)
- F" V6 I$ D4 m* \tg2 = Left(lz3, lz5 - 1)                                                                 'tg2等于lz3左側(cè)的lz5-1個字符
+ f: L% _' C. w! l$ K+ i# }
' e; p. V! n1 ~1 U; Z' O9 Vlz6 = Mid(lz3, lz5 + 1)                                                                  'lz6等于lz3第lz5+1個后面的所有字符
lz7 = InStr(lz6, "\")                                                                    'lz7為lz6由左向右搜索出第一個"\"字符在第幾個
+ e* g: O) u& H- b6 f' cIf lz7 > 0 Then                                                                          '當(dāng)lz7大于0時
tg3 = 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
* s- {  \( N+ I1 Y( B* Q4 ~'由后向前搜索“--”,第一個“--”向前到“\”間為產(chǎn)品編號（FGQ），向后到“\”間為產(chǎn)品名稱（定制角架），向后的第一個“\”和第二個間“\”，為版本號(2020版)。

& s4 c) S7 H6 A" N" c
# R9 f# n! I3 ?0 i+ |
bRet = swModel2.AddCustomInfo3("", "產(chǎn)品編號", swCustomInfoText, tg1)
bRet = swModel2.AddCustomInfo3("", "產(chǎn)品名稱", swCustomInfoText, tg2)
/ I  W5 ?6 E& I/ D6 QbRet = swModel2.AddCustomInfo3("", "版本號", swCustomInfoText, tg3)
bRet = swModel2.AddCustomInfo3("", "圖號", swCustomInfoText, tg4)
" |! o$ p4 s4 A2 m" ~6 bbRet = swModel2.AddCustomInfo3("", "Description", swCustomInfoText, tg5)
: F% n( z! D( v- f) F- @0 UbRet = swModel2.AddCustomInfo3("", "數(shù)量", swCustomInfoText, "1")
bRet = swModel2.AddCustomInfo3("", "備注1", swCustomInfoText, " ")
  L/ ?. x- d1 t9 j( MbRet = swModel2.AddCustomInfo3("", "備注2", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "備注3", swCustomInfoText, " ")
bRet = swModel2.AddCustomInfo3("", "Material", swCustomInfoText, tg6)
+ m# j) M$ n; J  w% hbRet = swModel2.AddCustomInfo3("", "SH", swCustomInfoText, tg7)
bRet = swModel2.AddCustomInfo3("", "重量", swCustomInfoText, tg8)
; `) V4 o, g  u# r7 d( m9 H& ^bRet = swModel2.AddCustomInfo3("", "表面積", swCustomInfoText, tg9)                         '此段為填寫自定義屬性項與其值

Dim thisFeat As SldWorks.Feature                                                         '另外增加一段宏，取讀取切割清單數(shù)據(jù)，并添加到屬性項。
! X1 R+ U5 r9 k" g2 r/ ODim thisSubFeat As SldWorks.Feature
" X; u; L( G" ~Dim cutFolder As Object
Dim BodyCount As Integer
Dim custPropMgr As SldWorks.CustomPropertyManager
% u) K7 u' {9 o# G5 f* fDim propNames As Variant
Dim vName As Variant
Dim propName As String
Dim Value As String
$ M5 \1 [; }/ f( C) b2 P- k  u1 hDim resolvedValue As String
Dim bjkcd As Double
Dim bjkkd As Double
'Sub main()
'Set swApp = Application.SldWorks
9 H* b5 n. S+ X* N7 E8 C" t8 sSet Part = swApp.ActiveDoc
Set thisFeat = Part.FirstFeature
# ^1 P( `/ j+ R6 X. FDo While Not thisFeat Is Nothing '遍歷設(shè)計樹
1 w2 l1 f+ C/ @+ R( k" fIf thisFeat.GetTypeName = "SolidBodyFolder" Then
thisFeat.GetSpecificFeature2.UpdateCutList
End If
Set thisSubFeat = thisFeat.GetFirstSubFeature
Do While Not thisSubFeat Is Nothing
. Q0 h; K% F' VIf thisSubFeat.GetTypeName = "CutListFolder" Then '查找切割清單
Set cutFolder = thisSubFeat.GetSpecificFeature2
, W4 w" p2 Q; }; s, t, wEnd If
. i. |$ m0 ]) K5 lIf Not cutFolder Is Nothing Then
: P' }5 h4 B3 U3 JBodyCount = cutFolder.GetBodyCount
If BodyCount > 0 Then
; H' Q( |, W/ k" q6 I$ V- L3 gSet 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
& Y$ h9 @* o9 \! B! bpropName = vName
custPropMgr.Get2 propName, Value, resolvedValue '獲取全部屬性名稱 ，數(shù)值和評估的值
; ?+ i" A$ o, {" `% |If propName = "邊界框長度" Then bjkcd = resolvedValue '判斷是否是自己所需要的數(shù)據(jù)，如果是就獲取
If propName = "邊界框?qū)挾?quot; Then bjkkd = resolvedValue
0 l, L9 y1 ~& ]7 N  ZNext vName
End If
# b! |2 d7 C$ J/ `/ ^9 `5 Z& @End If
. F9 a6 G! |% N% B$ DEnd If
) K9 z4 B4 S9 X/ c+ h. v3 cEnd If
- Z  l9 f$ `; \2 p! f* _Set thisSubFeat = thisSubFeat.GetNextSubFeature
& |1 {7 P2 K( i5 Z: G: _Loop
0 w; Q4 G5 e4 h: {- u( A; xSet thisFeat = thisFeat.GetNextFeature
Loop
2 A% H; T/ q' w' @0 H'blnretval = Part.DeleteCustomInfo2("", "邊界框長度") '刪除屬性欄上摘要信息的數(shù)據(jù)
'blnretval = Part.DeleteCustomInfo2("", "邊界框?qū)挾?quot;)
# @) Q' p  w; H0 w6 G! v1 K" q! Xblnretval = Part.AddCustomInfo3("", "開料長度", swCustomInfoText, bjkcd) '添加數(shù)據(jù)到摘要信息
2 g7 n" h( r' g* Cblnretval = Part.AddCustomInfo3("", "開料寬度", swCustomInfoText, bjkkd)
  M+ H9 J) J" U. S
End Sub
5 P; A$ g( U3 J6 e

遠(yuǎn)祥

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

曉昀

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

柴榮1917

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

tg-000057

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

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

meltemi

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