重命名零件宏

怕瓦落地2011

Solidworks 雖功能強(qiáng)大，但有些地方做得不盡如人意，比如三維帶工程圖重命名，就顯得十分雞肋。論壇網(wǎng)友steve_suich發(fā)過(guò)一個(gè)改零件同時(shí)改工程圖的宏（http://e-learninguniversity.com/thread-1058539-1-2.html）,雖然有所改進(jìn)，但不是十分完美。
我在此代碼的基礎(chǔ)上作些優(yōu)化，希望能給大家?guī)��?lái)幫助！
4 I; y) F5 Y) o# x0 Q
Ps:1.前置條件：打開(kāi)裝配體并選擇零件
1 D: F4 B$ W0 m( ]: c0 }; i% U; y    2.使用方法：運(yùn)行宏后輸入名稱(chēng)
/ W2 O8 n0 t/ }6 H3 L" M" ]$ c    3.運(yùn)行結(jié)果：同文件夾下生成新零件及附屬工程圖并保留原工程圖
; I: L! x+ S9 P- f, s! f7 z- y
$ D; U- [, o" K% x7 @( y% ~9 MDim swApp As Object
( h! S+ ?5 O$ e9 z; u6 z- o, h  Dim Part As Object
  Dim Error As Long
Dim Warning As Long
Dim mip As String
Dim Status As Boolean
6 n, T' B% R% M: C8 q. `Dim Newpath As String
Dim mipname As String
0 }$ X1 \. _3 R( @3 G8 t  l. T3 aDim vDepend() As String
6 o& B' l1 j( D* j; f% t    Sub main()
    Set swApp = Application.SldWorks
" m8 y  y( j9 W4 z5 B' x1 n    Set Part = swApp.ActiveDoc
( M: [: D) F7 b# P, f- Y    Set swSelMgr = Part.SelectionManager
! ~" D% a  W, I& W4 K    Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
        swComp.SetSuppression2 (3)   
) B$ r2 ^( I4 S# }7 |: e    Set swSelModel = swComp.GetModelDoc2
' v( e# i* @3 p5 z) l* r7 d    Set swSelModelext = swSelModel.Extension

    oldpathname = swComp.GetPathName
; d/ A8 Q: w0 T$ `& c  q! k   
    Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路徑
    Debug.Print Path
9 `  G, ?# L- b    ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后綴
    Debug.Print ntype
    oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '舊文件名
    Debug.Print oldfi
% c  b. b- p) s0 c    oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
         mipname = InputBox("changename", "name", oldname) '新文件名
         
         mip = Path & mipname & ntype '新文件名帶路徑
         Debug.Print mip

! |2 U. V: K, i1 U; H; O    If mip <> "" Then
         Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替換裝配體中的原文件）
      Debug.Print Status
0 s+ Y  _5 E( P4 E9 W( G      '========================
4 g: ]2 V) d5 Z" \) Y1 K! n+ P' d; V      '更改工程圖文件名
      Debug.Print Path
2 I5 X/ T: R7 H      tmpfi = Dir(Path & "*.SLDDRW") '遍歷原文件夾中的工程圖文件
      Debug.Print tmpfi
      Do Until tmpfi =Null
        tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
) \$ x# P, q% T        Debug.Print tmpfiname
' Y% [8 r7 B" k4 {. m3 f        tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
3 x& }6 h% _1 b9 |- v        Debug.Print tmpoldname
3 y& w$ t. A* t! X        If tmpfiname = tmpoldname Then '查找同名工程圖
* O/ i( F8 z, _% a1 j$ k' A        newdrwname = Path & mipname & ".SLDDRW"
        Debug.Print newdrwname
* o8 D5 k% `5 h& |! K7 Z        olddrwname = Path & tmpfi
         filecopy olddrwname,newdrwname '復(fù)制工程圖到新文件夾
        vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程圖依賴
0 \1 c0 P: ^3 Y        Debug.Print vDepend(1)
        bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替換工程圖依賴

- O9 L0 M( c4 [4 j        Debug.Print bl
. P8 _" o8 e/ m6 i: E, q" P) y5 V         Exit Do
% e4 Y+ p5 ^) d. V1 Z       End If
- h* B* w7 G! e7 [5 I( T    tmpfi = Dir
3 r6 `8 G- \2 N4 f    Debug.Print tmpfi
    Loop
. n. w- }; K, s    End If
    End Sub
; z$ t) l' L2 V- A4 s
& x+ V, [! X* P7 w. I

7 U  _3 i! x- H% n
7 Y* M  E9 M0 B) O) J7 ~4 ]' |

ィ心兂鎅

有版本限制嗎？

cc851

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

trongtrongtrong

凱元工具也可以批量改名

怕瓦落地2011

trongtrongtrong 發(fā)表于 2023-8-22 10:14
4 ~' k+ k3 W! i& S) _9 ]# e: V# j; [凱元工具也可以批量改名

授人以魚(yú)，不如授人以漁

shasu

謝謝版主 分享

liyizheng5566

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

liyizheng5566

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

lonelysnakejj

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

Dustry

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