Sub FnmPreCal() '预处理名称Dim i As Long, j As Long, SouRow1 As Long, SouRow2 As Long, ColStr As String With ThisWorkbook.ActiveSheet i = 3: SetGolDic Do While .Cells(i, PropTitDicA("文件全名")) <> "" .Cells(i, PropTitDicA("新文件全名")) = .Cells(i, PropTitDicA("新文件位置")) & "\" & _ .Cells(i, PropTitDicA("新SW模型名称")) & .Cells(i, PropTitDicA("扩展名")) If .Cells(i, PropTitDicA("新文件全名")) <> .Cells(i, PropTitDicA("文件全名")) Then If Dir(.Cells(i, PropTitDicA("新文件全名")), vbNormal) <> "" Then .Cells(i, PropTitDicA("操作类别")) = "直接替换" Else .Cells(i, PropTitDicA("操作类别")) = "带图复制" End If Else .Cells(i, PropTitDicA("操作类别")) = "不做修改" End If i = i + 1 Loop i = 3 ColStr = 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 = 0 If .Cells(i, PropTitDicA("新父阶")) <> .Cells(i, PropTitDicA("父阶")) Or _ .Cells(i, PropTitDicA("新子阶")) <> .Cells(i, PropTitDicA("子阶")) Then .Cells(i, PropTitDicA("操作类别2")) = "执行操作" Else .Cells(i, PropTitDicA("操作类别2")) = "不做修改" End If i = i + 1 Loop End With MsgBox "表格内文件名称已预处理," & 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 String Set fs = CreateObject("Scripting.FileSystemObject") With ThisWorkbook.ActiveSheet i = 3: SetGolDic Do 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, NewModelNm If Dir(OldDrwNm, vbNormal) <> "" Then fs.CopyFile OldDrwNm, NewDrwNm swApp.ReplaceReferencedDocument NewDrwNm, OldModelNm, NewModelNm End If .Cells(i, PropTitDicA("操作结果")) = "已复制!" Case "带图改名" If Dir(OldModelNm, vbNormal) <> "" Then Set mfl = fs.GetFile(OldModelNm) mfl.Name = .Cells(i, PropTitDicA("新SW模型名称")) & .Cells(i, PropTitDicA("扩展名")) End If If Dir(OldDrwNm, vbNormal) <> "" Then Set drwfl = fs.GetFile(OldDrwNm) drwfl.Name = .Cells(i, PropTitDicA("新SW模型名称")) & ".SLDDRW" swApp.ReplaceReferencedDocument NewDrwNm, OldModelNm, NewModelNm End If .Cells(i, PropTitDicA("操作结果")) = "已改名!" End Select i = i + 1 Loop i = 3 Do While .Cells(i, PropTitDicA("父阶")) <> "" If .Cells(i, PropTitDicA("操作类别2")) = "执行操作" Then swApp.ReplaceReferencedDocument .Cells(i, PropTitDicA("新父阶")), .Cells(i, PropTitDicA("子阶")), .Cells(i, PropTitDicA("新子阶")) End If i = i + 1 Loop End With Set fs = Nothing MsgBox "已对模型/工程图名称做相应处理,请先打开顶层装配重建并保存!", vbInformation, "不正经的机械仙人"End Sub
