重命名零件宏

怕瓦落地2011

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

1 L& N" L' X7 Z& n9 s( kPs:1.前置条件：打开装配体并选择零件
! Q  _& V/ ]3 `" W& X* u' [    2.使用方法：运行宏后输入名称
; ~& s: Z8 G% I) h' y    3.运行结果：同文件夹下生成新零件及附属工程图并保留原工程图
0 U' w5 ~$ K8 T, W
4 p6 h7 \3 Y1 y; pDim swApp As Object
  Dim Part As Object
1 {$ y1 h! D" s  S' u  Dim Error As Long
0 O: J8 c( |$ L  y% u7 y- kDim Warning As Long
7 z, ]' I9 I4 F" L: M4 x/ ADim mip As String
5 K" O, r) {# g4 C- w3 [8 \9 WDim Status As Boolean
) w$ T6 v* I0 `0 A' ^Dim Newpath As String
8 O3 P" C6 }5 J* U) W$ q, }( _Dim mipname As String
Dim vDepend() As String
; m' p6 ]+ q, U% g6 q  `    Sub main()
2 W1 A# H. d+ u- w& \5 S; s    Set swApp = Application.SldWorks
    Set Part = swApp.ActiveDoc
    Set swSelMgr = Part.SelectionManager
    Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
        swComp.SetSuppression2 (3)   
5 d, G, U" @0 @    Set swSelModel = swComp.GetModelDoc2
4 \1 M. Z; Y, |# b2 t    Set swSelModelext = swSelModel.Extension

3 B) Z7 t' i: B( r, |    oldpathname = swComp.GetPathName
# P" D2 b  j3 P8 i: W   
    Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路径
    Debug.Print Path
    ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后缀
    Debug.Print ntype
3 V# `0 J* [3 n7 @    oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '旧文件名
    Debug.Print oldfi
( B9 m) M8 s8 P* [# d    oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
         mipname = InputBox("changename", "name", oldname) '新文件名
         
         mip = Path & mipname & ntype '新文件名带路径
         Debug.Print mip
+ X1 p* ~" v6 i' ~3 u
: S6 `- `2 m+ q* `    If mip <> "" Then
         Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替换装配体中的原文件）
      Debug.Print Status
      '========================
8 c! I& H5 S5 ^. I      '更改工程图文件名
: y: I9 H/ N( H! D( {4 T      Debug.Print Path
2 M' R- l' t2 r$ H! C7 x* ^      tmpfi = Dir(Path & "*.SLDDRW") '遍历原文件夹中的工程图文件
) |9 U6 X+ M6 @8 I2 t      Debug.Print tmpfi
7 A6 u9 Y; O$ H; k2 b      Do Until tmpfi =Null
+ ~6 J: o0 O! Z0 O- _9 [2 _' h% Z        tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
) P7 y. n8 t( X& H( V        Debug.Print tmpfiname
6 _  @. q, N  }* d5 A, S' N        tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
1 @3 l3 `: d) h# t; \        Debug.Print tmpoldname
6 G5 b$ @0 y: e. f: W        If tmpfiname = tmpoldname Then '查找同名工程图
# ^5 o1 u. v: I6 S3 Z% ?' `; |' H+ h6 L        newdrwname = Path & mipname & ".SLDDRW"
        Debug.Print newdrwname
        olddrwname = Path & tmpfi
         filecopy olddrwname,newdrwname '复制工程图到新文件夹
, y' H0 h7 o1 F0 M) g        vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程图依赖
        Debug.Print vDepend(1)
. \  Z5 l" i; |5 S: \1 k8 g        bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替换工程图依赖
0 q/ w1 Z5 R) z9 P& s# U
' C7 i# W6 |9 l2 L$ z        Debug.Print bl
         Exit Do
4 a7 S( T) R8 Q- J. g: d5 t       End If
2 t: V! @+ i. J1 _+ |. m; ~( [, n1 t    tmpfi = Dir
1 _0 |/ W1 s5 ~  ]- l    Debug.Print tmpfi
% j* q% _% [2 r8 t6 @+ o2 Y0 }    Loop
+ k7 S5 F; P- I. d. d* z4 n9 }    End If
    End Sub

2 T+ P" T7 W& G$ P3 H
, @+ A2 @9 c  ]) m
9 c. G! F( L" {" |+ x/ t6 C5 @
. M' Q. A9 s* n" S3 y# q" e5 Y" t
. m& ]' J8 p" P' w

小菜鸡123

怕瓦落地2011 发表于 2023-8-22 21:14
授人以鱼，不如授人以渔

! F; F1 e' J$ n2 T4 k& b为什么复制了代码，点击了启动，没有反应，重新启动也没有反应，代码里面红色的，这个有关系吗？

cot

感谢

落叶luoyi

提示编译错误：没有适当的对象，方法无效
4 ?' j' m+ L# e1 i4 K大佬，这个怎么修改啊

头铁杨

好用，如果再加个删除原图纸就更完美了

peiyj

运行出错

Dustry

Dustry 发表于 2024-4-3 13:29
. ~6 r3 }7 p; S5 G& }& K+ }) l运行报错咋解决啊大佬

Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning)  '更改零件文件名（替换装配体中的原文件）
对象不支持这个属性或方法（错误 438）
; i  ~+ h6 D2 a: z, l0 S

Dustry

运行报错咋解决啊大佬
3 _4 [( U7 p  n' ]: M: I8 b

lonelysnakejj

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

liyizheng5566

显示代码错误 一片红