关于闷大“宏: 從零件直接開啟檔名不一致的工程圖”这个帖子，实操的讨论

flooding · 发表于 2020-6-5 09:40:53

闷大原帖：
icax.org/thread-927493-1-3.html

原帖公布的代码：

Sub main()
Set swApp = Application.SldWorks
Set Model = swApp.ActiveDoc
If Model Is Nothing Then Exit Sub
ModelPathName = Model.GetPathName
ModelConfigName = swApp.GetActiveConfigurationName(ModelPathName) '當前模型的當前配置名稱
ModelPath = Left(ModelPathName, InStrRev(ModelPathName, ""))
ModelName = Right(ModelPathName, Len(ModelPathName) - Len(ModelPath))
DrawingFileName = Dir(ModelPath & "*.slddrw") '獲取首個工程圖檔案名稱
NoDrawingFound = True
Do Until DrawingFileName = "" '直至獲取到空值
traverse = False 'True
search = False
addreadonlyinfo = False
depends = swApp.GetDocumentDependencies2(ModelPath & DrawingFileName, traverse, search, addreadonlyinfo) '工程圖含有的全部模型檔案名稱
WithModel = False
If Not IsEmpty(depends) Then
      idx = 1
      While idx <= UBound(depends)
         If ModelPathName = depends(idx) Then WithModel = True '工程圖是否含有當前模型檔案名稱
         idx = idx + 2
      Wend
End If
If WithModel Then '是否含有當前模型檔案名稱
      Set Drawing = swApp.OpenDoc(ModelPath & DrawingFileName, 3) '開啟工程圖
      Dim longstatus As Long
      swApp.ActivateDoc2 DrawingFileName, False, longstatus  '顯示工程圖
      myViewss = Drawing.GetViews '所有視圖
      ModelConfigInDrawing = False
      For i = 0 To UBound(myViewss) '每頁
         myViews = myViewss(i)
         SheetName = myViews(0).Name '每頁圖頁名稱
         ModelInSheet = False
         For j = 0 To UBound(myViews)
            If ModelPathName = myViews(j).GetReferencedModelName And ModelConfigName = myViews(j).ReferencedConfiguration Then '模型檔名及配置名稱都吻合
                  ModelInSheet = True
                  ModelConfigInDrawing = True
            End If
         Next
         If ModelInSheet Then Drawing.ActivateSheet SheetName '跳到含有當前模型及配置的圖頁
      Next
      If Not ModelConfigInDrawing Then '開啟了的工程圖不吻合所有條件
         MsgBox "此工程圖雖然含有 " & ModelName & Chr(10) & "但沒有對應的配置 " & ModelConfigName '如覺得此提示信息有阻礙, 可整句刪除
         swApp.ActivateDoc2 ModelPathName, False, longstatus '顯示本來的模型 (雖然開啟了的工程圖不吻合條件, 但必須保持開啟, 以免影響其他當前工作)
      End If
      NoDrawingFound = False
End If
DrawingFileName = Dir '獲取下一個工程圖檔案名稱
Loop '循環
If NoDrawingFound Then MsgBox "在資料夾 " & ModelPath & Chr(10) & "找不到含有 " & ModelName & " 的工程圖" '如覺得此提示信息有阻礙, 可整句刪除
End Sub

问题：
1 此宏使用的情形应该是零件或者装配体和它们不同名的工程图同在一个文件夹内的吧？
2 正常情况，工程图都是单图吧？闷大后来完善了代码，可以打开同档多个工程图里面对应的工程图

看到很多人试用了说好，为什么我就没成功呢？
哪位大神有时间给解释下吗？

我使用的情形：
1 在一个文件夹做了一套零件（零件图和工程图都是配套的）

2 把工程图改名

3 运行宏了没用

闷大的代码我都没改，直接搬运用的：

还担心不行，把他的三段都试了都不行

补充内容 (2020-6-12 10:48):
ModelPath = Left(ModelPathName, InStrRev(ModelPathName, "")改成：
ModelPath = Left(ModelPathName, InStrRev(ModelPathName, "\"))

就可以解决

谢谢@xiaocake