重命名零件宏

怕瓦落地2011

Solidworks 雖功能強大，但有些地方做得不盡如人意，比如三維帶工程圖重命名，就顯得十分雞肋。論壇網友steve_suich發過一個改零件同時改工程圖的宏（http://www.odgf.cn/thread-1058539-1-2.html）,雖然有所改進，但不是十分完美。
我在此代碼的基礎上作些優化，希望能給大家帶來幫助！
  V) I8 P7 v7 D& K4 p
8 c- q& g& g  P4 N6 g7 j+ ~Ps:1.前置條件：打開裝配體并選擇零件
( b' @6 [7 i9 Q% h4 w2 r    2.使用方法：運行宏后輸入名稱
: F9 }: j; _; y* U. R; H) F3 i    3.運行結果：同文件夾下生成新零件及附屬工程圖并保留原工程圖

Dim swApp As Object
  Dim Part As Object
4 q+ z5 P2 n" ~# o# i  Dim Error As Long
2 f2 p# }. n, A+ kDim Warning As Long
  J0 X0 t! S4 g2 {  y- M9 ODim mip As String
1 @: e. r! |$ w7 h4 {Dim Status As Boolean
Dim Newpath As String
Dim mipname As String
- Y/ \  X% \* F5 }4 Y4 DDim vDepend() As String
    Sub main()
    Set swApp = Application.SldWorks
5 ~% a; L, @, \5 Q' j. p    Set Part = swApp.ActiveDoc
    Set swSelMgr = Part.SelectionManager
    Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
        swComp.SetSuppression2 (3)   
    Set swSelModel = swComp.GetModelDoc2
& f3 U! ?$ Y0 U8 z* D2 [# E0 H    Set swSelModelext = swSelModel.Extension

( _; N& V9 x2 I$ l9 u    oldpathname = swComp.GetPathName
   
    Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路徑
( v. Y, `& M  F) _; Q+ ]    Debug.Print Path
4 D. `# M( `& v3 C8 @, `    ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后綴
    Debug.Print ntype
    oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '舊文件名
    Debug.Print oldfi
    oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
         mipname = InputBox("changename", "name", oldname) '新文件名
! P! o. Q* @( V8 T# f         
; N5 B7 b- |2 c9 W9 p, C' K7 F% N         mip = Path & mipname & ntype '新文件名帶路徑
         Debug.Print mip
$ _+ O; X9 k, q3 C: {; j+ n
5 Y8 ^- ~4 y, ]/ X: ~7 P% r    If mip <> "" Then
         Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替換裝配體中的原文件）
( ~( @7 }- _! w      Debug.Print Status
& X" n6 c4 c! ^, S  k; e/ M      '========================
" ~& C! j5 C$ m7 C0 F" S8 B( s$ Q      '更改工程圖文件名
      Debug.Print Path
" R  ~, o  }- W7 {! S: f# l      tmpfi = Dir(Path & "*.SLDDRW") '遍歷原文件夾中的工程圖文件
9 I9 i+ M$ \( i+ U) H      Debug.Print tmpfi
      Do Until tmpfi =Null
" T6 z) E' o& u! J; Q) ?        tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
5 {- n, t$ b" ?" U        Debug.Print tmpfiname
8 a2 J( M% u2 M: x        tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
        Debug.Print tmpoldname
9 {& o0 z4 I% o        If tmpfiname = tmpoldname Then '查找同名工程圖
        newdrwname = Path & mipname & ".SLDDRW"
7 P& f$ R* b3 k4 B7 M        Debug.Print newdrwname
' N8 ^: I4 e1 q        olddrwname = Path & tmpfi
         filecopy olddrwname,newdrwname '復制工程圖到新文件夾
8 n# D! p+ T6 E& q0 Y! f        vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程圖依賴
        Debug.Print vDepend(1)
0 u) j, i' G5 J( R; }( ^        bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替換工程圖依賴
( N& `( p3 e( X) y$ c3 m- h
        Debug.Print bl
         Exit Do
6 y% l( q: c( V9 H& I       End If
( l' D1 L/ H( F# K8 U- F, U1 m    tmpfi = Dir
3 ^4 K8 g6 @$ Z9 h( `& z3 K    Debug.Print tmpfi
    Loop
    End If
' `, G2 i2 y) x1 C/ h    End Sub


" w: J. r4 W) d9 A


! K4 O( _) i8 b3 C. P* |5 W

ィ心兂鎅

有版本限制嗎？

cc851

Solidworks自帶命名，就是不能關聯工程圖一起改而已。從設計流程來說，改名在出圖之前。其實就無所謂要不要插件了。

trongtrongtrong

凱元工具也可以批量改名

怕瓦落地2011

trongtrongtrong 發表于 2023-8-22 10:14
凱元工具也可以批量改名

授人以魚，不如授人以漁
# _. T' a: i# s. W

shasu

謝謝版主 分享

liyizheng5566

復制粘貼過去代碼錯誤

liyizheng5566

顯示代碼錯誤 一片紅

lonelysnakejj

怎么拷貝好一些，復制都是亂碼

Dustry

運行報錯咋解決啊大佬