solidworks真是不思进取，连个关联图纸一起重命名的功能都没有，但这并不是因为它不能实现，只是因为开发根本就不能从用户实际需求去考虑问题，你文件另存为的时候直接关联上同名的图纸文件不就完了吗，只能自己写个宏文件，需要的朋友自己copy一下吧。
& o o$ f( J0 y8 A* j: A5 b9 k$ l: T* a+ h4 `. o5 {
Dim swApp As Object
* D7 Z$ \# |9 M3 O3 v7 l/ _& yDim ActiveDoc As Object
5 j+ m& M4 o% M2 G( jDim Error As Long9 A; G" n1 }2 `% I! u+ u
Dim Warning As Long
: g3 Y9 w6 M- g7 tDim NewName As String
7 A$ o: g9 E' l* m6 _Dim NewPathName As String# t8 S9 h6 j- B H2 u
Dim Status As Boolean; H7 m" }; F0 q0 `' S, L
Dim vDepend() As String
& k" a2 Z: M3 n
o; ~& R) }9 ?
' ^5 N9 O# J& t$ n, a3 wSub main()
0 u" s. w+ W) l; `$ x3 e Set swApp = Application.SldWorks
/ [5 C& O& T. [) f ^3 I' w, b Set ActiveDoc = swApp.ActiveDoc
8 k s; @$ o, v3 }* m& {: }' ` Set swSelMgr = ActiveDoc.SelectionManager8 u: e, C k& k2 b! C
Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0)& f' _; ]0 P" \ Q
3 }6 I" N _$ \ '判断是否选择了当前文件子装配体对象
6 N2 O6 @9 v& T' | If swSelMgr.GetSelectedObjectCount2(0) = 0 Then# q( K. r4 B. U% D; S2 V q3 O
MsgBox "当前功能只能对装配体里的子文件进行重命名", vbOKOnly, "提示信息"
+ p: X- }! h2 o7 F; p( C Else
! m9 s; J$ k J# {, y; K swComp.SetSuppression2 (3)1 i: M' A7 h& L
Set swSelModel = swComp.GetModelDoc2
$ t* } H2 _, n Set swSelModelext = swSelModel.Extension
8 ]2 w4 G0 A3 |% Z# }. m! L8 C
% C' o$ j7 V7 `# C. C3 b OldPathName = swComp.GetPathName
1 E1 a5 S {1 V( P4 W* D$ x5 b Path = Left(OldPathName, InStrRev(OldPathName, "\")) '路径
8 R @0 S1 `# _7 f Suffix = Mid(OldPathName, InStrRev(OldPathName, ".")) '后缀
5 T% {0 I0 I5 s( o- N6 P OldNameWithSuffix = Mid(OldPathName, InStrRev(OldPathName, "\") + 1) '带后缀的旧文件名
' I0 |) d2 f$ L7 a7 ?+ G1 }) y$ D, l" B: g7 F+ H
OldName = Left(OldNameWithSuffix,InStrRev(OldNameWithSuffix,".")-1)
5 s$ b0 B4 [1 ^5 E4 v6 B+ @$ T; \ NewName = InputBox("另存为新文件名：","更新文件名对话框",OldName)'输入新文件名
( K. ? L7 [" N4 T2 u8 u3 Z NewPathName = Path & NewName & Suffix '新文件名带路径* |. Q+ |% x' a- T, @
/ h3 T) v9 R7 z( X7 R If NewPathName <> "" And NewName <> OldName Then
6 n0 `" [, O% u Status = swSelModelext.SaveAs3(NewPathName, 0, 512, Nothing, Nothing, Error, Warning) '将旧文件直接另存为新文件
: G8 L* b1 u6 p/ p7 `0 I h" g Kill OldPathName '删除旧文件0 x/ A- E% A8 |! ^
3 E3 K) u2 _3 U: e& L3 n temFile = Dir(Path & OldName & ".SLDDRW") '只要返回值不为空就表明该文件是有工程图纸的，返回值是有后缀的文件名7 U7 O! L& _( l" X9 D4 f
If temFile <> "" Then
# L6 l3 e: j. l- q! b* K NewDrwName = Path & NewName & ".SLDDRW"1 ]: N% [7 j: b. x. C5 P
OldDrwName = Path & OldName & ".SLDDRW"
2 O, K1 z" `- h. `+ `) U$ u- g, t FileCopy OldDrwName , NewDrwName '复制工程图为新文件8 Z, U4 H! N! a6 z+ H( I1 J5 v1 r \) k
vDepend = swApp.GetDocumentDependencies2(OldDrwName, False, False, False) '查找旧文件工程图依赖3 d A* j0 S# g' n" @
Rp = swApp.ReplaceReferencedDocument(NewDrwName, vDepend(1), NewPathName) '替换工程图依赖
/ p$ W+ o0 i7 q" M4 r Kill OldDrwName! G, I4 B! o' }
Else) g$ J/ N/ k: w/ Q0 h
MsgBox "文件没有工程图纸", vbOKOnly, "提示信息". |1 y+ m& I2 @
End If
# Q4 ~& R" o4 m Else
6 U$ J9 a# m0 w& q MsgBox "无效的新文件名，请冲洗输入", vbOKOnly, "提示信息", n, M8 P9 `: |$ I. h6 _
End If
( w% T) G6 _, a/ b% }, P- ]( P1 }0 W& }
End If
: m8 j* D7 S, S3 q
) b9 X; g! H1 Q+ `7 o0 D. C# _End Sub
& L5 R. O B. f* @( T. S) v
: G: o4 s3 a3 X5 O/ H6 ]/ ~, V/ D; T
) f& E0 n) n: L1 V" [% C4 k) z/ x) e8 {, D0 y: T& c" U3 p
, \# {6 V8 y5 E" E& A3 D
|
发表于 2025-1-9 21:19:54
