重命名零件宏

[復(fù)制鏈接]

怕瓦落地2011

電梯直達(dá)

1^#

發(fā)表于 2023-8-21 21:07:44 | 只看該作者 |倒序?yàn)g覽 |閱讀模式

Solidworks 雖功能強(qiáng)大，但有些地方做得不盡如人意，比如三維帶工程圖重命名，就顯得十分雞肋。論壇網(wǎng)友steve_suich發(fā)過(guò)一個(gè)改零件同時(shí)改工程圖的宏（http://www.hrhome.com.cn/thread-1058539-1-2.html）,雖然有所改進(jìn)，但不是十分完美。
我在此代碼的基礎(chǔ)上作些優(yōu)化，希望能給大家?guī)?lái)幫助！

Ps:1.前置條件：打開(kāi)裝配體并選擇零件
2.使用方法：運(yùn)行宏后輸入名稱(chēng)
3.運(yùn)行結(jié)果：同文件夾下生成新零件及附屬工程圖并保留原工程圖

Dim swApp As Object
  Dim Part As Object
  Dim Error As Long
Dim Warning As Long
Dim mip As String
Dim Status As Boolean
Dim Newpath As String
Dim mipname As String
Dim vDepend() As String
Sub main()
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
Set swSelMgr = Part.SelectionManager
Set swComp= swSelMgr.GetSelectedObjectsComponent4(1,0）
      swComp.SetSuppression2 (3)
Set swSelModel = swComp.GetModelDoc2
Set swSelModelext = swSelModel.Extension

oldpathname = swComp.GetPathName

Path = Left(oldpathname, InStrRev(oldpathname, "\")) '路徑
Debug.Print Path
ntype = Mid(oldpathname, InStrRev(oldpathname, ".")) '后綴
Debug.Print ntype
oldfi = Mid(oldpathname, InStrRev(oldpathname, "\") + 1) '舊文件名
Debug.Print oldfi
oldname = Left(oldfi, InStrRev(oldfi, ".") - 1)
      mipname = InputBox("changename", "name", oldname) '新文件名

      mip = Path & mipname & ntype '新文件名帶路徑
      Debug.Print mip

If mip <> "" Then
      Status = swSelModelext.SaveAs3(mip, 0, 512, Nothing, Nothing, Error, Warning) '更改零件文件名（替換裝配體中的原文件）
   Debug.Print Status
   '========================
   '更改工程圖文件名
   Debug.Print Path
   tmpfi = Dir(Path & "*.SLDDRW") '遍歷原文件夾中的工程圖文件
   Debug.Print tmpfi
   Do Until tmpfi =Null
      tmpfiname = Mid(tmpfi, InStrRev(tmpfi, "\") + 1)
      Debug.Print tmpfiname
      tmpoldname=mid(oldfi,1,instr(1,oldfi,".")-1) & ".SLDDRW"
      Debug.Print tmpoldname
      If tmpfiname = tmpoldname Then '查找同名工程圖
      newdrwname = Path & mipname & ".SLDDRW"
      Debug.Print newdrwname
      olddrwname = Path & tmpfi
      filecopy olddrwname,newdrwname '復(fù)制工程圖到新文件夾
      vDepend = swApp.GetDocumentDependencies2(Path & tmpfi, False, False, False) '查找工程圖依賴(lài)
      Debug.Print vDepend(1)
      bl = swApp.ReplaceReferencedDocument(newdrwname, vDepend(1), mip) '替換工程圖依賴(lài)

      Debug.Print bl
      Exit Do
   End If
tmpfi = Dir
Debug.Print tmpfi
Loop
End If
End Sub