SolidWorks*Excel+VBA-正式改名字了,带上工程图
- 2026-11-10 06:31:09
SolidWorks*Excel+VBA-正式改名字了,带上工程图来吧，这次让我们好好地把模型/工程图文件名称捋捋顺。 接上回，模型装配关系已经扒拉下来了，下一步当然是要改名字，改完名字先做预处理，初步判断下是带图复制还是直接替换，也可自行选择是否直接改名字。这里呢仅针对文件，还没到装配关系。 
然后这里根据程序计算出的新旧父阶/子阶关系进行判断是否需要进行处理操作。 
程序如下： 纯粹的表格内数据匹配对照操作，逻辑不是特别复杂，调用的子程序在以往文章中都有，这里就不再展开介绍了。可以对照视频。 预处理结束，然后第二步，实打实操作文件名称并且更新装配/工程图的引用关系，看程序 先改名或复制，然后替换关系，逻辑也不复杂，主要是API调用。 文章中示例程序仅为基础功能，未做具体细部的错误处理，并不能涵盖所有情况。 数据无价，尤其是费尽心血做出的设计资料，测试前请做好备份，备份，备份，重要的事情说3遍。 
已关注
关注
重播 分享 赞
Sub FnmPreCal() '预处理名称Dim i As Long, j As Long, SouRow1 As Long, SouRow2 As Long, ColStr As StringWith ThisWorkbook.ActiveSheeti = 3: SetGolDicDo While .Cells(i, PropTitDicA("文件全名")) <> "".Cells(i, PropTitDicA("新文件全名")) = .Cells(i, PropTitDicA("新文件位置")) & "\" & _.Cells(i, PropTitDicA("新SW模型名称")) & .Cells(i, PropTitDicA("扩展名"))If .Cells(i, PropTitDicA("新文件全名")) <> .Cells(i, PropTitDicA("文件全名")) ThenIf Dir(.Cells(i, PropTitDicA("新文件全名")), vbNormal) <> "" Then.Cells(i, PropTitDicA("操作类别")) = "直接替换"Else.Cells(i, PropTitDicA("操作类别")) = "带图复制"End IfElse.Cells(i, PropTitDicA("操作类别")) = "不做修改"End Ifi = i + 1Loopi = 3ColStr = Split(Columns(PropTitDicA("文件全名")).Address, "$")(2)Do While .Cells(i, PropTitDicA("父阶")) <> ""SouRow1 = GetRefVal(.Cells(i, PropTitDicA("父阶")), .Range(ColStr & ":" & ColStr))SouRow2 = GetRefVal(.Cells(i, PropTitDicA("子阶")), .Range(ColStr & ":" & ColStr))If SouRow1 <> 0 Then .Cells(i, PropTitDicA("新父阶")) = .Cells(SouRow1, PropTitDicA("新文件全名"))If SouRow2 <> 0 Then .Cells(i, PropTitDicA("新子阶")) = .Cells(SouRow2, PropTitDicA("新文件全名"))SouRow1 = 0: SouRow2 = 0If .Cells(i, PropTitDicA("新父阶")) <> .Cells(i, PropTitDicA("父阶")) Or _.Cells(i, PropTitDicA("新子阶")) <> .Cells(i, PropTitDicA("子阶")) Then.Cells(i, PropTitDicA("操作类别2")) = "执行操作"Else.Cells(i, PropTitDicA("操作类别2")) = "不做修改"End Ifi = i + 1LoopEnd WithMsgBox "表格内文件名称已预处理," & Chr(13) & _"请确认操作类别后再执行更名操作!", vbInformation, "不正经的机械仙人"End Sub
Sub DsfsReName() '带图改名/复制Dim i As Long, fs As FileSystemObject, mfl As File, drwfl As File, aaDim OldModelNm As String, OldDrwNm As String, NewModelNm As String, NewDrwNm As StringSet fs = CreateObject("Scripting.FileSystemObject")With ThisWorkbook.ActiveSheeti = 3: SetGolDicDo While .Cells(i, PropTitDicA("文件全名")) <> "".Cells(i, PropTitDicA("操作结果")) = ""OldModelNm = .Cells(i, PropTitDicA("文件全名"))OldDrwNm = .Cells(i, PropTitDicA("文件位置")) & "\" & .Cells(i, PropTitDicA("SW模型文件名")) & ".SLDDRW"NewModelNm = .Cells(i, PropTitDicA("新文件全名"))NewDrwNm = .Cells(i, PropTitDicA("新文件位置")) & "\" & .Cells(i, PropTitDicA("新SW模型名称")) & ".SLDDRW"Select Case .Cells(i, PropTitDicA("操作类别"))Case "不做修改".Cells(i, PropTitDicA("操作结果")) = "未修改!"Case "直接替换".Cells(i, PropTitDicA("操作结果")) = "仅替换!"Case "带图复制"If Dir(OldModelNm, vbNormal) <> "" Then fs.CopyFile OldModelNm, NewModelNmIf Dir(OldDrwNm, vbNormal) <> "" Thenfs.CopyFile OldDrwNm, NewDrwNmswApp.ReplaceReferencedDocument NewDrwNm, OldModelNm, NewModelNmEnd If.Cells(i, PropTitDicA("操作结果")) = "已复制!"Case "带图改名"If Dir(OldModelNm, vbNormal) <> "" ThenSet mfl = fs.GetFile(OldModelNm)mfl.Name = .Cells(i, PropTitDicA("新SW模型名称")) & .Cells(i, PropTitDicA("扩展名"))End IfIf Dir(OldDrwNm, vbNormal) <> "" ThenSet drwfl = fs.GetFile(OldDrwNm)drwfl.Name = .Cells(i, PropTitDicA("新SW模型名称")) & ".SLDDRW"swApp.ReplaceReferencedDocument NewDrwNm, OldModelNm, NewModelNmEnd If.Cells(i, PropTitDicA("操作结果")) = "已改名!"End Selecti = i + 1Loopi = 3Do While .Cells(i, PropTitDicA("父阶")) <> ""If .Cells(i, PropTitDicA("操作类别2")) = "执行操作" ThenswApp.ReplaceReferencedDocument .Cells(i, PropTitDicA("新父阶")), .Cells(i, PropTitDicA("子阶")), .Cells(i, PropTitDicA("新子阶"))End Ifi = i + 1LoopEnd WithSet fs = NothingMsgBox "已对模型/工程图名称做相应处理,请先打开顶层装配重建并保存!", vbInformation, "不正经的机械仙人"End Sub
本文来自网友投稿或网络内容，如有侵犯您的权益请联系我们删除，联系邮箱：wyl860211@qq.com 。
