宏: 從零件開啟多頁工程圖並自動跳到含有該零件的圖頁

学习一下,支持一下

谢谢  学习中

学习闷招！

看看，学习学习！谢谢

学习大大的优秀操作

试了好几次，也没有实现闷大的功能，仔细查看了代码以后，感觉双引号内少了\，擅自修改发布代码，如有失礼之处，请多包涵。只为帮助更多人...

1. Sub main()
   
2. Set swApp = Application.SldWorks
   
3. Set Model = swApp.ActiveDoc
   
4. If Model Is Nothing Then Exit Sub
   
5. ModelPathName = Model.GetPathName
   
6. ModelConfigName = swApp.GetActiveConfigurationName(ModelPathName) '當前模型的當前配置名稱
   
7. ModelPath = Left(ModelPathName, InStrRev(ModelPathName, ""))
   
8. ModelName = Right(ModelPathName, Len(ModelPathName) - Len(ModelPath))
   
9. DrawingFileName = Dir(ModelPath & "*.slddrw") '獲取首個工程圖檔案名稱
   
10. NoDrawingFound = True
    
11. Do Until DrawingFileName = "" '直至獲取到空值
    
12.     traverse = False 'True
    
13.     Search = False
    
14.     addreadonlyinfo = False
    
15.     depends = swApp.GetDocumentDependencies2(ModelPath & DrawingFileName, traverse, Search, addreadonlyinfo) '工程圖含有的全部模型檔案名稱
    
16.     WithModel = False
    
17.     If Not IsEmpty(depends) Then
    
18.         idx = 1
    
19.         While idx <= UBound(depends)
    
20.             If ModelPathName = depends(idx) Then WithModel = True '工程圖是否含有當前模型檔案名稱
    
21.             idx = idx + 2
    
22.         Wend
    
23.     End If
    
24.     If WithModel Then '是否含有當前模型檔案名稱
    
25.         Set Drawing = swApp.OpenDoc(ModelPath & DrawingFileName, 3) '開啟工程圖
    
26.         Dim longstatus As Long
    
27.         swApp.ActivateDoc2 DrawingFileName, False, longstatus  '顯示工程圖
    
28.         myViewss = Drawing.GetViews '所有視圖
    
29.         ModelConfigInDrawing = False
    
30.         For i = 0 To UBound(myViewss) '每頁
    
31.             myViews = myViewss(i)
    
32.             SheetName = myViews(0).Name '每頁圖頁名稱
    
33.             ModelInSheet = False
    
34.             For j = 0 To UBound(myViews)
    
35.                 If ModelPathName = myViews(j).GetReferencedModelName And ModelConfigName = myViews(j).ReferencedConfiguration Then '模型檔名及配置名稱都吻合
    
36.                     ModelInSheet = True
    
37.                     ModelConfigInDrawing = True
    
38.                 End If
    
39.             Next
    
40.             If ModelInSheet Then Drawing.ActivateSheet SheetName '跳到含有當前模型及配置的圖頁
    
41.         Next
    
42.         
    
43.         If Not ModelConfigInDrawing Then '開啟了的工程圖不吻合所有條件
    
44.         
    
45.         
    
46.             MsgBox "此工程圖雖然含有 " & ModelName & Chr(10) & "但沒有對應的配置 " & ModelConfigName '如覺得此提示信息有阻礙, 可整句刪除
    
47.          
    
48.             swApp.ActivateDoc2 ModelPathName, False, longstatus    '顯示本來的模型 (雖然開啟了的工程圖不吻合條件, 但必須保持開啟, 以免影響其他當前工作)
    
49.             
    
50.         End If
    
51.         
    
52.         NoDrawingFound = False
    
53.         
    
54.     End If
    
55.    
    
56.     DrawingFileName = Dir '獲取下一個工程圖檔案名稱
    
57.    
    
58. Loop '循環
    
59. 
    
60. If NoDrawingFound Then MsgBox "在文件夹 " & ModelPath & Chr(10) & "找不到含有 " & ModelName & " 的工程图" '如覺得此提示信息有阻礙, 可整句刪除
    
61. 
    
62. End Sub
    
63. 
    

复制代码

可能是论坛系统问题，我上传的代码里面"\"也消失不见了。具体是代码的第7行的双引号内添加\即可。

多谢，挺方便

虽然这种需求不多,也会有用的时候,下来看看

看一下看一下

闷大的帖子要好好琢磨一下。