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

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

xiaocake 发表于 2020-6-5 20:03
你有没有拿另外的模型及其配套的工程图试验吗？

flooding 发表于 2020-6-6 08:12
这是刚试的。还是不行。
昨天研究了一天没找到原因才发帖求助
——我试怀疑是不是自己不会用可 ...

xiaocake 发表于 2020-6-6 19:32
ModelPath = Left(ModelPathName, InStrRev(ModelPathName, "")改成：
ModelPa ...