重命名零件宏

怕瓦落地2011

Solidworks 雖功能強(qiáng)大，但有些地方做得不盡如人意，比如三維帶工程圖重命名，就顯得十分雞肋。論壇網(wǎng)友steve_suich發(fā)過一個(gè)改零件同時(shí)改工程圖的宏（http://www.whclglass.com.cn/thread-1058539-1-2.html）,雖然有所改進(jìn)，但不是十分完美。
0 G1 C! q2 S( |6 W; C) r我在此代碼的基礎(chǔ)上作些優(yōu)化，希望能給大家?guī)韼椭?br /> ! t" E0 Z* n) J8 B. B' N
Ps:1.前置條件：打開裝配體并選擇零件
    2.使用方法：運(yùn)行宏后輸入名稱
" l8 N! W2 O* k, p! @  ]4 _; ?    3.運(yùn)行結(jié)果：同文件夾下生成新零件及附屬工程圖并保留原工程圖
2 F/ R5 G3 c! F6 t9 m* Q& ]0 x
: t) z) O' p/ |Dim swApp As Object
  Dim Part As Object
  Dim Error As Long
$ x9 E8 H- M0 [! V9 w) vDim Warning As Long
Dim mip As String
, x2 H! k! f6 e' k$ F" ^Dim Status As Boolean
Dim Newpath As String
Dim mipname As String
Dim vDepend() As String
    Sub main()
+ T3 \6 Z; @/ d: F1 |    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
    Set swSelMgr = Part.SelectionManager
* N6 `6 F7 n( A    Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
        swComp.SetSuppression2 (3)   
    Set swSelModel = swComp.GetModelDoc2
    Set swSelModelext = swSelModel.Extension
6 g  p% B. y. `/ B. |% f' j. T$ _
$ j& D1 H$ U8 m    oldpathname = swComp.GetPathName
9 y3 x  |- W- r5 [1 P$ ]' H3 c   
) c% P6 i% }" [' E    Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路徑
    Debug.Print Path
    ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后綴
4 P# ]! c/ A3 w0 c, M( s+ p( w- c    Debug.Print ntype
    oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '舊文件名
0 R) b# K# W, M2 D3 ^3 S4 U; r( k6 u    Debug.Print oldfi
2 S" ~. ]+ v1 _" ]- }% g. H    oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
1 Z/ ~. E9 B- \5 m/ E; X$ M4 T         mipname = InputBox("changename", "name", oldname) '新文件名
         
% g2 G' [) Z: E4 C3 h         mip = Path & mipname & ntype '新文件名帶路徑
         Debug.Print mip

- o  E; l7 h0 H- H! [- A    If mip <> "" Then
         Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替換裝配體中的原文件）
      Debug.Print Status
3 S) b  l& ~4 i2 N: ^4 H" Q+ O; @      '========================
      '更改工程圖文件名
      Debug.Print Path
$ V6 U  {- v( ?# s7 u% e      tmpfi = Dir(Path & "*.SLDDRW") '遍歷原文件夾中的工程圖文件
      Debug.Print tmpfi
3 g' s4 P4 X) ?& l      Do Until tmpfi =Null
        tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
        Debug.Print tmpfiname
        tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
9 U' `9 J$ s' {  S8 V( R        Debug.Print tmpoldname
        If tmpfiname = tmpoldname Then '查找同名工程圖
9 z  r/ ~7 P. F4 s7 V) g) ], ?( l        newdrwname = Path & mipname & ".SLDDRW"
+ @+ }. P  x7 \" n        Debug.Print newdrwname
        olddrwname = Path & tmpfi
         filecopy olddrwname,newdrwname '復(fù)制工程圖到新文件夾
! C" b& n3 s- Z' C' R) t0 |2 _        vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程圖依賴
        Debug.Print vDepend(1)
        bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替換工程圖依賴
4 @* H, r) L/ ^) d
* J0 y6 s. `+ n) R2 v1 h        Debug.Print bl
         Exit Do
" K7 Q; W/ s# C1 p% ^% O+ k       End If
# y5 g0 l; A3 `9 r/ M+ L    tmpfi = Dir
0 h0 C$ I+ j6 j" d9 ~$ T- v    Debug.Print tmpfi
/ o( s' V. J# `. {4 n! B    Loop
    End If
    End Sub
" d$ ]6 `) G) D! i6 |

7 I% ]$ o, G8 L. P7 h# R
2 S$ R4 ^& t; G% G
0 W' P9 G) y9 O4 \7 }5 [
! q+ K7 n0 I/ \% @3 v; R3 t, [0 V

ィ心兂鎅

有版本限制嗎？

cc851

Solidworks自帶命名，就是不能關(guān)聯(lián)工程圖一起改而已。從設(shè)計(jì)流程來說，改名在出圖之前。其實(shí)就無所謂要不要插件了。

trongtrongtrong

凱元工具也可以批量改名

怕瓦落地2011

trongtrongtrong 發(fā)表于 2023-8-22 10:14
' q' {4 |* q1 B3 o1 ~凱元工具也可以批量改名

授人以魚，不如授人以漁

shasu

謝謝版主 分享

liyizheng5566

復(fù)制粘貼過去代碼錯(cuò)誤

liyizheng5566

顯示代碼錯(cuò)誤 一片紅

lonelysnakejj

怎么拷貝好一些，復(fù)制都是亂碼

Dustry

運(yùn)行報(bào)錯(cuò)咋解決啊大佬