重命名零件宏

怕瓦落地2011

Solidworks 虽功能强大，但有些地方做得不尽如人意，比如三维带工程图重命名，就显得十分鸡肋。必威APP精装版下载网友steve_suich发过一个改零件同时改工程图的宏（//www.szfco.com/thread-1058539-1-2.html）,虽然有所改进，但不是十分完美。
我在此代码的基础上作些优化，希望能给大家带来帮助！

# T+ I6 h( m0 j4 P. R  Q$ H9 DPs:1.前置条件：打开装配体并选择零件
6 L# h4 |! \* F) R4 I; c    2.使用方法：运行宏后输入名称
2 i$ ]% j$ J8 \0 Q    3.运行结果：同文件夹下生成新零件及附属工程图并保留原工程图

- f/ \2 L0 L/ x9 B" r  TDim swApp As Object
" O6 P# a4 X$ B. [% F  |# a5 z; ^  Dim Part As Object
  Dim Error As Long
  H, K. h1 k$ Q5 }- kDim Warning As Long
2 ]* s2 y0 f0 c' WDim mip As String
9 O& D3 W& @  H: S6 cDim Status As Boolean
: O  Q$ s. \/ e6 V' ]2 \# ?3 A) E. uDim Newpath As String
: G6 Q* w5 f6 o+ gDim mipname As String
: g) L* D1 K5 \; HDim vDepend() As String
    Sub main()
    Set swApp = Application.SldWorks
% E9 r0 z  t) v5 Q# h    Set Part = swApp.ActiveDoc
; e0 a6 B" W) B3 [) r    Set swSelMgr = Part.SelectionManager
  H9 X$ S9 t+ E) y6 }' \    Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
        swComp.SetSuppression2 (3)   
  z; l5 U0 w6 S    Set swSelModel = swComp.GetModelDoc2
    Set swSelModelext = swSelModel.Extension
. F4 [8 @' c( h0 G( l
    oldpathname = swComp.GetPathName
   
    Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路径
  p8 o* z3 W9 z$ d. N    Debug.Print Path
& V0 d% X$ {& m3 k: h    ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后缀
* K4 c1 \; e% J, i" R. B    Debug.Print ntype
    oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '旧文件名
9 U3 H, C% `+ E3 ~5 T& G    Debug.Print oldfi
2 g6 `1 g. f& L0 Y7 O    oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
         mipname = InputBox("changename", "name", oldname) '新文件名
0 _6 w: O- z4 ?  H3 Y# p         
6 t6 B; `$ X9 r: o         mip = Path & mipname & ntype '新文件名带路径
         Debug.Print mip

' b9 b0 T  g( C% [    If mip <> "" Then
         Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替换装配体中的原文件）
% M' ?# N: Y% `7 M, V' H      Debug.Print Status
& ~- ]) p8 M4 }/ y9 {5 C$ z      '========================
. Z* u5 T. O& V: e      '更改工程图文件名
      Debug.Print Path
6 n! Q% n% |* W- r4 I6 R: c$ B" h      tmpfi = Dir(Path & "*.SLDDRW") '遍历原文件夹中的工程图文件
      Debug.Print tmpfi
      Do Until tmpfi =Null
1 z. M2 M$ q' K3 q- D0 z        tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
        Debug.Print tmpfiname
        tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
" H, V) l) F. m: @/ k        Debug.Print tmpoldname
        If tmpfiname = tmpoldname Then '查找同名工程图
  N8 R' i+ R0 C% K9 L  b6 `0 I3 c        newdrwname = Path & mipname & ".SLDDRW"
1 c- M( k% [4 I# s        Debug.Print newdrwname
2 _) U! J1 T* ^        olddrwname = Path & tmpfi
$ P! r$ I! c, y6 Y, L8 y4 M         filecopy olddrwname,newdrwname '复制工程图到新文件夹
        vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程图依赖
        Debug.Print vDepend(1)
        bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替换工程图依赖
5 ^4 Y8 F+ }$ c5 L/ {
; a7 a4 S1 J6 v8 |1 F! q2 ^7 \        Debug.Print bl
         Exit Do
9 \; ^3 L/ T# J' T) {/ j# l0 x       End If
    tmpfi = Dir
6 M9 h2 ?* l' P4 _7 `# o- {    Debug.Print tmpfi
" I( O5 h0 M$ `' L- V    Loop
. r6 R7 c9 b  @# c    End If
    End Sub

! w5 k  y% Z1 l/ H



1 d2 }4 h( m3 P$ L: h# X$ Y/ a; }" ]6 k

ィ心兂鎅

有版本限制吗？

cc851

Solidworks自带命名，就是不能关联工程图一起改而已。从设计流程来说，改名在出图之前。其实就无所谓要不要插件了。

trongtrongtrong

凯元工具也可以批量改名

怕瓦落地2011

trongtrongtrong 发表于 2023-8-22 10:14
; J5 G. y5 c* r  @+ y4 N/ X凯元工具也可以批量改名

. S/ c, x1 {( S: d0 G7 y. J授人以鱼，不如授人以渔
" v8 a) s" D( K5 H, V

shasu

谢谢版主 分享

liyizheng5566

复制粘贴过去代码错误

liyizheng5566

显示代码错误 一片红

lonelysnakejj

怎么拷贝好一些，复制都是乱码

Dustry

运行报错咋解决啊大佬