重命名零件宏

怕瓦落地2011

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

6 S2 c+ d, U' M6 pPs:1.前置条件：打开装配体并选择零件
4 C) p2 P1 n6 ^4 h3 w    2.使用方法：运行宏后输入名称
) z+ |9 E) V; |$ G& x, Z: |! J& J    3.运行结果：同文件夹下生成新零件及附属工程图并保留原工程图

Dim swApp As Object
  Dim Part As Object
  B5 a$ d9 X0 i- u  r, D# j  Dim Error As Long
Dim Warning As Long
* K0 V# ^, E$ p' T( I. J2 P' k. ~Dim mip As String
Dim Status As Boolean
6 Z0 [$ [6 A1 [% W# z( ?Dim Newpath As String
) U3 s& f+ {( Z, H' S3 `Dim mipname As String
- @8 ?; m" _. Y! f2 a$ KDim vDepend() As String
    Sub main()
$ ?8 W/ N( \+ z" W7 o- o% Y    Set swApp = Application.SldWorks
* W! j: _( F& ~    Set Part = swApp.ActiveDoc
    Set swSelMgr = Part.SelectionManager
8 g* E+ l& k6 d; G7 C- `    Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
# e' _* A( L& h" T. v        swComp.SetSuppression2 (3)   
    Set swSelModel = swComp.GetModelDoc2
    Set swSelModelext = swSelModel.Extension

    oldpathname = swComp.GetPathName
   
    Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路径
    Debug.Print Path
7 j0 p; u9 V: {3 v  @* Q! v; I    ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后缀
    Debug.Print ntype
' g9 e" _% |$ R2 N1 Q    oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '旧文件名
9 }5 o) d7 H2 v; r- i) B+ E    Debug.Print oldfi
    oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
         mipname = InputBox("changename", "name", oldname) '新文件名
, v6 |5 Q5 F1 j0 l) r         
         mip = Path & mipname & ntype '新文件名带路径
/ j9 U# c( r; D. R8 k9 J$ f         Debug.Print mip
0 ]$ ?- q6 m+ P) y
: n1 R- N# _& Q- r" v5 {    If mip <> "" Then
/ v+ ~& k7 M/ a% k$ M" ?; k9 `4 g         Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替换装配体中的原文件）
      Debug.Print Status
1 D. }5 W8 Q7 D' T6 i      '========================
$ @" i1 o0 J" A1 a. q      '更改工程图文件名
: |5 G& e) z$ T4 }% t      Debug.Print Path
( l1 x8 X) y2 z% n4 H+ x( i      tmpfi = Dir(Path & "*.SLDDRW") '遍历原文件夹中的工程图文件
      Debug.Print tmpfi
      Do Until tmpfi =Null
# D- I# d- _5 b        tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
6 v" Z1 |# Z: w$ L+ Y3 Y        Debug.Print tmpfiname
4 a: A% L4 C$ P% m. A- J        tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
( f* u9 l! G; V! V- K- h1 `        Debug.Print tmpoldname
# y' f5 d- ~8 e$ F        If tmpfiname = tmpoldname Then '查找同名工程图
, F4 `2 S) y3 s. J$ a/ g        newdrwname = Path & mipname & ".SLDDRW"
        Debug.Print newdrwname
, r- P$ G6 U' {: _3 S+ r        olddrwname = Path & tmpfi
2 H% @! m' J# [0 }; |         filecopy olddrwname,newdrwname '复制工程图到新文件夹
        vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程图依赖
        Debug.Print vDepend(1)
        bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替换工程图依赖
9 y5 l) n" ^- U7 [; e. N
4 U9 X7 ~/ p7 ?/ j4 O, ^        Debug.Print bl
" z; F  P  Z* o( x7 {         Exit Do
8 {2 C7 `  g, Q/ a! {% t  L       End If
    tmpfi = Dir
    Debug.Print tmpfi
    Loop
3 A1 D9 Z7 R6 w' R# l6 G    End If
9 T- `# q9 R  P1 o+ u    End Sub
& {0 Z) h1 g$ {
; @$ Z" @/ I% [  f
+ M3 z  n, t" z7 d( J
3 L" T4 L0 B! D& u

+ y& [& S/ ^) O1 M

ィ心兂鎅

有版本限制吗？

cc851

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

trongtrongtrong

凯元工具也可以批量改名

怕瓦落地2011

trongtrongtrong 发表于 2023-8-22 10:14
7 {3 a. O! F  x. M凯元工具也可以批量改名

* c7 u$ y1 N$ L# l授人以鱼，不如授人以渔
+ A1 _/ t! O. M; c+ |0 O

shasu

谢谢版主 分享

liyizheng5566

复制粘贴过去代码错误

liyizheng5566

显示代码错误 一片红

lonelysnakejj

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

Dustry

运行报错咋解决啊大佬
" I. u# W$ d; B  ~! `! j2 [3 S) }