Sub 热改名(ByVal 旧文件名全名, ByVal 新文件名全名, ByRef 释放锁定或关闭的文件, ByRef 是否成功) Set fso = CreateObject("Scripting.FileSystemObject") On Error Resume Next fso.MoveFile 旧文件名全名, 新文件名全名 '释放锁定后再次尝试改名 If Err.Number <> 0 Then If UCase(Right(旧文件名全名, 3)) <> "DRW" Then Set kkswModel = swApp.GetOpenDocumentByName(旧文件名全名) nRetVal = kkswModel.ForceReleaseLocks 释放锁定或关闭的文件.Add 旧文件名全名, kkswModel Else swApp.CloseDoc 旧文件名全名 释放锁定或关闭的文件.Add 旧文件名全名, 新文件名全名 End If Err.Clear On Error Resume Next fso.MoveFile 旧文件名全名, 新文件名全名 If Err.Number <> 0 Then AppActivate ThisWorkbook.Name MsgBox "热改名打开的文件出错", vbInformation 是否成功 = False End If End If Set fso = Nothing 是否成功 = True End Sub Sub 重载或替换文件(ByVal 释放了锁定的文件) For Each k In 释放了锁定的文件.keys Set kkswModel = 释放了锁定的文件(k) On Error Resume Next nRetVal重载 = kkswModel.ReloadOrReplace(False, k, True) If nRetVal重载 <> 0 Then Debug.Print k & "重载有异常! nRetVal重载=" & nRetVal重载, vbInformation End If Next End Sub Sub 热替换参考(ByVal sw全名, ByVal 旧文件名, ByVal 新文件名全名, ByRef 释放了锁定的文件, ByRef 是否成功) Debug.Print sw全名 bRet = swApp.ReplaceReferencedDocument(sw全名, 旧文件名, 新文件名全名) If Not bRet Then Set kkswModel = swApp.GetOpenDocumentByName(sw全名) On Error Resume Next nRetVal = kkswModel.ForceReleaseLocks 释放了锁定的文件.Add sw全名, kkswModel On Error Resume Next bRet = swApp.ReplaceReferencedDocument(sw全名, 旧文件名, 新文件名全名) If bRet Then 是否成功 = True End If End If 是否成功 = True End Sub
Sub 键入路径找关联() Set sw全部文件字典 = CreateObject("Scripting.Dictionary") Call 遍历文件夹(Range("默认路径") & "", sw全部文件字典, "全部") For Each Key In sw全部文件字典.keys Call 查引用(Key, sw全部文件字典) Next Set sw三维文件字典 = CreateObject("Scripting.Dictionary") For Each Key In sw全部文件字典.keys If InStr(1, Key, ".SLDDRW", 1) = 0 Then sw三维文件字典.Add Key, "" Next 清除 Set 文件名行号 = CreateObject("Scripting.Dictionary") Call 列出文件全名(sw三维文件字典, 文件名行号) Call 列出关联文件(文件名行号, sw全部文件字典) End Sub Sub 列表文件找关联() Set 表字典 = CreateObject("Scripting.Dictionary") Call Excel转字典(表字典) Set 搜索路径 = CreateObject("Scripting.Dictionary") Set 文件名行号 = CreateObject("Scripting.Dictionary") For Each 行 In 表字典.Items 行("文件路径").Select 搜索路径(行("文件路径").Value) = "" ' sw全名 = Cells(当前行, 文件路径列号) & Cells(当前行, 文件名称列号) & "." & Cells(当前行, 格式列号) sw全名 = 行("文件路径") & 行("文件名称") & "." & 行("格式") 文件名行号(sw全名) = 行("文件路径").Row Next Set sw全部文件字典 = CreateObject("Scripting.Dictionary") For Each k In 搜索路径.keys Call 遍历文件夹(k, sw全部文件字典, "全部") Next For Each Key In sw全部文件字典.keys Call 查引用(Key, sw全部文件字典) Next Call 列出关联文件(文件名行号, sw全部文件字典) End Sub
Sub 遍历文件夹(ByVal 文件夹路径, ByRef sw全部文件字典, ByVal 范围) Dim MyName, Dic, i, t, F, TT, MyFileName t = Time Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象 ' Dic.Add Range("默认路径") & "", "" Dic.Add 文件夹路径, "" If 搜索子文件夹 Then i = 0 Do While i < Dic.Count ke = Dic.keys '开始遍历字典 MyName = Dir(ke(i), vbDirectory) '查找目录 Do While MyName <> "" If MyName <> "." And MyName <> ".." Then Debug.Print ke(i) & MyName kk = 32 On Error Resume Next kk = GetAttr(ke(i) & MyName) If (kk And vbDirectory) = vbDirectory Then '如果是次级目录 If Not 含其中之一V2(MyName, Range("路径黑名单关键词").Value) Then Dic.Add (ke(i) & MyName & ""), "" '就往字典中添加这个次级目录名作为一个条目 End If End If End If MyName = Dir '继续遍历寻找 Loop i = i + 1 Loop End If For Each ke In Dic.keys MyFileName = Dir(ke & "*.SLDPRT") Do While MyFileName <> "" ' sw全部文件字典.Add (ke & MyFileName), "" sw全部文件字典(ke & MyFileName) = "" MyFileName = Dir Loop Next For Each ke In Dic.keys MyFileName = Dir(ke & "*.SLDASM") Do While MyFileName <> "" sw全部文件字典(ke & MyFileName) = "" MyFileName = Dir Loop Next If 范围 = "全部" Then For Each ke In Dic.keys MyFileName = Dir(ke & "*.SLDDRW") Do While MyFileName <> "" sw全部文件字典(ke & MyFileName) = "" MyFileName = Dir Loop Next End If End Sub
Sub 列出关联文件(ByVal 文件名行号, ByVal sw全部文件字典) Dim str As String For Each FilePathName In 文件名行号.keys 当前行 = 文件名行号(FilePathName) Cells(当前行, 关联工程列号).Select Call 拆分文件名(FilePathName) 关联工程图 = "" 关联零部件 = "" For Each Key In sw全部文件字典.keys If Not IsEmpty(sw全部文件字典(Key)) Then Debug.Print Join(sw全部文件字典(Key), "") If InStr(1, Join(sw全部文件字典(Key), ""), Filename, 1) <> 0 Then If InStr(1, Key, ".SLDDRW", 1) <> 0 Then 关联工程图 = 关联工程图 & "|" & Key If InStr(1, Key, ".SLDDRW", 1) = 0 Then 关联零部件 = 关联零部件 & "|" & Key End If End If Next Cells(当前行, 关联工程列号) = 关联工程图 Cells(当前行, 关联工程列号 + 1) = UBound(Split(关联工程图, "|")) Cells(当前行, 关联零部件列号) = 关联零部件 Cells(当前行, 关联零部件列号 + 1) = UBound(Split(关联零部件, "|")) Next End Sub
Sub 查引用(ByVal 文件名, ByRef sw全部文件字典) Dim swApp As SldWorks.SldWorks Dim swModel As SldWorks.ModelDoc2 Dim vDepend As Variant Dim bRet As Boolean Dim i As Long Set swApp = CreateObject("SldWorks.Application") vDepend = swApp.GetDocumentDependencies2(文件名, False, True, False) ' Debug.Print sDocName ' If IsEmpty(vDepend) Then ' Debug.Print " No dependencies" ' Exit Sub ' End If ' For i = 0 To (UBound(vDepend) - 1) / 2 ' Debug.Print " " + vDepend(2 * i) + " --> " + vDepend(2 * i + 1) ' Next i sw全部文件字典(文件名) = vDepend End Sub
Sub 读取属性(ByVal 配置特定属性) 获取行列号 文件个数 = 1 For 当前行 = 首行 To 末行 Cells(当前行, 文件路径列号).Select If ActiveCell.Interior.ColorIndex = "-4142" Then '只处理无填充色的行==开始 sw全名 = Cells(当前行, 文件路径列号) & Cells(当前行, 文件名称列号) & "." & Cells(当前行, 格式列号) Call sw初始化_获取指定文件(sw全名) 配置名 = "" If Not 配置特定属性 Then Set cusPropMgr = swModel.Extension.CustomPropertyManager("") Else 配置名 = Cells(当前行, 配置列) ' Value = swModel.ShowConfiguration2(配置名) ' Set config = swModel.GetActiveConfiguration Set config = swModel.GetConfigurationByName(配置名) Set cusPropMgr = config.CustomPropertyManager End If Dim lRetVal As Long Dim ValOut As String Dim ResolvedValOut As String Dim wasResolved As Boolean For 列号 = 代号列号 To 末列 Cells(当前行, 列号).Select 属性名 = Cells(表头行, 列号) lRetVal = cusPropMgr.Get5(属性名, False, ValOut, ResolvedValOut, wasResolved) ActiveCell = ValOut ' ActiveCell = ResolvedValOut Next 列号 文件个数 = 文件个数 + 1 End If '只处理无填充色的行==结束 Next 当前行 End Sub Sub 属性cs() Call sw初始化("") Set cusPropMgr = swModel.Extension.CustomPropertyManager("") propNames = cusPropMgr.GetNames If Not IsEmpty(propNames) Then For Each vName In propNames Debug.Print vName ' custPropMgr.Get2 propName, Value, resolvedValue ' If propName = "重量" Then Weight = resolvedValue ' If propName = "DESCRIPTION" Then pName = resolvedValue Next vName End If End Sub
Sub 改名模块() c = Timer Dim PathName As String Dim 旧文件名 As String Dim 新文件名 As String Dim 关联文件() As String Dim 关联工程图() As String Dim 新工程图 As String Dim fso As Object Dim bRet As Boolean Set swApp = CreateObject("SldWorks.Application") '启动SW 有重复 = False Set 表字典 = CreateObject("Scripting.Dictionary") Call Excel转字典(表字典) Set 拟改名字典 = CreateObject("Scripting.Dictionary") ' For Each 行 In 表字典.Items ' 行("文件名称").Select ' 旧文件名 = 行("文件路径") & 行("文件名称") & "." & 行("格式") ' 拟改名字典.Add 旧文件名, 行 ' Next For Each 行 In 表字典.Items 行("拟改文件名称").Select 旧文件名 = 行("文件路径") & 行("文件名称") & "." & 行("格式") 新文件名 = 行("文件路径") & 行("拟改文件名称") & "." & 行("格式") If 新文件名 <> 旧文件名 Then If Not 拟改名字典.Exists(新文件名) Then 拟改名字典.Add 新文件名, 行 Else 有重复 = True 行("拟改文件名称").Interior.ColorIndex = 3 ' 拟改名字典(新文件名)("文件名称").ColorIndex = 3 End If End If Next If 有重复 Then MsgBox "拟改文件名称中存在重名，请修改！", vbInformation Exit Sub End If Call 移动文件(拟改名字典) '如果文件夹中已存在同名文件 Set 释放了锁定的文件 = CreateObject("Scripting.Dictionary") Set 关闭了的工程图 = CreateObject("Scripting.Dictionary") For Each 行 In 表字典.Items 行("文件名称").Select 行("文件名称").Interior.Pattern = xlNone 行("拟改文件名称").Interior.Pattern = xlNone 行("关联工程图").Interior.Pattern = xlNone 行("关联零部件").Interior.Pattern = xlNone 旧文件名 = 行("文件名称") & "." & 行("格式") 旧名称无后缀 = 行("文件名称") 新文件名 = 行("拟改文件名称") & "." & 行("格式") 新名称无后缀 = 行("拟改文件名称") If Not (行("文件名称").Interior.ColorIndex = 15 Or _ 旧文件名 = 新文件名 Or 新名称无后缀 = "") Then PathName = 行("文件路径") 旧文件名全名 = PathName & 旧文件名 新文件名全名 = PathName & 新文件名 是否成功 = False Call 热改名(旧文件名全名, 新文件名全名, 释放了锁定的文件, 是否成功) If Not 是否成功 Then Exit Sub 行("文件名称").Interior.ColorIndex = 43 行("拟改文件名称").Interior.ColorIndex = 43 '旧名称保留到拟该名称栏备用 行("文件名称").Value = Left(新文件名, Len(新文件名) - 7) 行("拟改文件名称").Value = Left(旧文件名, Len(旧文件名) - 7) '改名后替换excel中关联零部件文件名称 For Each 行kk In 表字典.Items ' 行kk("关联零部件").Select If InStr(1, 行kk("关联零部件"), 旧文件名, vbTextCompare) <> 0 Then 行kk("关联零部件").Value = Replace(行kk("关联零部件"), 旧文件名, 新文件名) 行kk("关联零部件").Interior.ColorIndex = 43 End If Next '改名后修改关联工程图名称 If 行("数量1") > -1 Then 行("关联工程图").Select 关联工程图 = Split(ActiveCell, "|") For ii = 1 To UBound(关联工程图) If 行("数量1") = 1 Then 新工程图 = PathName & 新名称无后缀 & ".SLDDRW" ElseIf InStr(1, 关联工程图(ii), 旧名称无后缀, vbTextCompare) <> 0 Then 新工程图 = Replace(关联工程图(ii), 旧名称无后缀, 新名称无后缀) Else 新工程图 = "" End If If 新工程图 <> "" Then ' fso.MoveFile 关联工程图(ii), 新工程图 是否成功 = False Call 热改名(关联工程图(ii), 新工程图, 关闭了的工程图, 是否成功) If Not 是否成功 Then Exit Sub '改工程图名称后替换excel中关联工程图文件名称 For Each 行kk In 表字典.Items ' 行kk("关联工程图").Select If InStr(1, 行kk("关联工程图"), 关联工程图(ii), 1) <> 0 Then 行kk("关联工程图").Value = Replace(行kk("关联工程图"), 关联工程图(ii), 新工程图) 行kk("关联工程图").Interior.ColorIndex = 43 End If Next End If Next ii End If '改名后替换参考文件 行("关联工程图").Select 关联文件 = Split(行("关联工程图") & 行("关联零部件"), "|") For j = 1 To UBound(关联文件) ' If Not 关联文件(j) = PathName & 新文件名 Then ' Debug.Print 关联文件(j) & "==" & 旧文件名 & "==" & PathName & 新文件名 ' bRet = swApp.ReplaceReferencedDocument(关联文件(j), 旧文件名, PathName & 新文件名) 是否成功 = False Call 热替换参考(关联文件(j), 旧文件名, PathName & 新文件名, 释放了锁定的文件, 是否成功) If Not 是否成功 Then 行("关联工程图").Interior.ColorIndex = 3 行("关联零部件").Interior.ColorIndex = 3 ' MsgBox "文件改名后，对关联文件进行参考文件替换时出错，请手动处理", vbInformation ' Exit Sub End If ' End If Next End If Next Call 重载或替换文件(释放了锁定的文件) For Each k In 关闭了的工程图.keys Set swModel = swApp.OpenDoc(关闭了的工程图(k), 3) Next If Not swApp.Visible Then swApp.ExitApp End If costTime = Format(Timer - c, "0.00") MsgBox "文件改名完成！ 耗时：" & costTime & "秒", vbInformation End Sub Sub cs() kk = Split("|", "|") For i = 1 To UBound(kk) Debug.Print kk(i) Next End Sub
Sub 移动文件(ByVal 拟移动文件字典) Set 已经处理文件 = CreateObject("Scripting.Dictionary") 文件个数 = 1 Set fso = CreateObject("Scripting.FileSystemObject") 'Call sw初始化("") Set swApp = CreateObject("SldWorks.Application") For Each sw全名 In 拟移动文件字典.keys If "" <> Dir(sw全名) Then Call 拆分文件名(sw全名) If 文件个数 = 1 Then '先创建目录 拟移动路径 = Cells(首行, 文件路径列号) & "移动文件" If "" <> Dir(拟移动路径, 16) Then a = Format(Date, "yymmdd") '当前年月日 b = Format(Time, "hhmmss") '当前时间 拟移动路径 = 拟移动路径 & "=" & a & "." & b End If VBA.MkDir (拟移动路径) End If NewFileName = 拟移动路径 & "" & Filename On Error Resume Next fso.MoveFile sw全名, NewFileName If Err.Number <> 0 Then Set kkswModel = swApp.GetOpenDocumentByName(sw全名) nRetVal = kkswModel.ForceReleaseLocks Err.Clear fso.MoveFile sw全名, NewFileName End If 已经处理文件.Add sw全名, "" 文件个数 = 文件个数 + 1 End If Next For Each k In 已经处理文件.keys Call 拆分文件名(k) 同名工程图 = FilePath & FilenameWHZ & ".SLDDRW" If "" <> Dir(同名工程图) Then Call 拆分文件名(同名工程图) NewFileName = 拟移动路径 & "" & Filename fso.MoveFile 同名工程图, NewFileName End If Next Set fso = Nothing End Sub
Sub 列出文件夹() Set swApp = CreateObject("SldWorks.Application") Dim MyName, Dic, i, t, F, TT, MyFileName t = Time Set Dic = CreateObject("Scripting.Dictionary") '创建一个字典对象 主文件夹路径 = Range("列出文件夹") & "" MyName = Dir(主文件夹路径, vbDirectory) '查找目录 Do While MyName <> "" If MyName <> "." And MyName <> ".." Then If (GetAttr(主文件夹路径 & MyName) And vbDirectory) = vbDirectory Then '如果是次级目录 Dic.Add (MyName), "" '就往字典中添加这个次级目录名作为一个条目 End If End If MyName = Dir '继续遍历寻找 Loop Range("列出文件夹").Offset(1, 0).Select For Each ke In Dic.keys ActiveCell = ke ActiveCell.Offset(1, 0).Select Next End Sub
