自动工程图宏--自动建立带有6个标准视图和4个轴测视图的工程图文件

'条件:当前开启零件或装配图
'结果:自动建立带有6个标准视图和4个轴测视图的工程图文件,并保存及另存为同名加后缀6+4的DWG文件
'注意:1工程图6+4.DRWDOT模板文件与宏文件同目录
        2.如在模型图中更新前视视图,则得到理想的主视图,得到理想的DWG

原理:根据工程图模板建立空白工程图文件,插入模型
       重新对齐和调整位置避免视图重叠
       保存工程图
       另存为DWG

1. ' ******************************************************************************
   
2. ' autodraw.swp - By PYCZT, Copyright 2016-2018  writed on 06/28/16
   
3. ' Notes: Templatesfile must be in same directory as macro file  注意:工程图6+4.DRWDOT模板文件与宏文件同目录
   
4. 
   
5. '条件:当前开启零件或装配图
   
6. '结果:自动建立带有6个标准视图和4个轴测视图的工程图文件,并保存和另存为同名加后缀6+4的DWG文件
   
7. '如在模型图中更新前视视图,则得到理想的主视图,得到理想的DWG
   
8. 
   
9. '******************************************************************************
   
10. Dim swApp As Object
    
11. Dim swModel As Object
    
12. Dim swDraw As Object
    
13. Dim swModelName As String
    
14. Dim Templatesfile As String
    
15. Dim boolstatus As Boolean
    
16. Dim swView As Object
    
17. Dim vOutline()    As Variant
    
18. Dim vPos()        As Variant
    
19. Dim nNumView      As Long
    
20. Dim box(3)     As Single
    
21. Dim longstatus As Long, longwarnings As Long
    
22. 
    
23. Sub main()
    
24. 
    
25. Set swApp = Application.SldWorks
    
26. Set swModel = swApp.ActiveDoc
    
27. swModelName = swModel.GetPathName      '读取当前SW模型文档名(含路径)
    
28. 
    
29. Templatesfile = swApp.GetCurrentMacroPathName             ' Get macro path+filename 取得宏路径和名称
    
30. Templatesfile = Left$(Templatesfile, Len(Templatesfile) - 12) + "工程图6+4.DRWDOT"    ' Set  Templates file name 设工程图模板名称
    
31. Set swDraw = swApp.NewDocument(Templatesfile, 0, 0, 0)   '以模板建立工程图
    
32. boolstatus = swDraw.InsertModelInPredefinedView(swModelName)  '在工程图中插入当前的模型
    
33. 
    
34. '四个轴测图取消对齐关系(重新定位)
    
35. boolstatus = swDraw.ActivateView("工程图视图7")
    
36. boolstatus = swDraw.Extension.SelectByID2("工程图视图7", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
    
37. Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
    
38. boolstatus = swView.RemoveAlignment
    
39. 
    
40. boolstatus = swDraw.ActivateView("工程图视图8")
    
41. boolstatus = swDraw.Extension.SelectByID2("工程图视图8", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
    
42. Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
    
43. boolstatus = swView.RemoveAlignment
    
44. 
    
45. boolstatus = swDraw.ActivateView("工程图视图9")
    
46. boolstatus = swDraw.Extension.SelectByID2("工程图视图9", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
    
47. Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
    
48. boolstatus = swView.RemoveAlignment
    
49. 
    
50. boolstatus = swDraw.Extension.SelectByID2("工程图视图10", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
    
51. Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
    
52. boolstatus = swView.RemoveAlignment
    
53. 
    
54. swDraw.ClearSelection2 True
    
55. 
    
56. 'Drawing views are repositioned so that none of them overlap.以下重新定位视图以免重叠
    
57. 
    
58. nNumView = 0
    
59. 
    
60. Set swView = swDraw.GetFirstView
    
61. 
    
62.     Do While Not swView Is Nothing
    
63. 
    
64.         ReDim Preserve vOutline(nNumView)
    
65.         ReDim Preserve vPos(nNumView)
    
66. 
    
67.         vOutline(nNumView) = swView.GetOutline
    
68.         vPos(nNumView) = swView.Position
    
69. 
    
70.         Debug.Print "View = " + swView.GetName2
    
71.         Debug.Print "  Pos = (" & vPos(nNumView)(0) * 1000# & ", " & vPos(nNumView)(1) * 1000# & ") mm"
    
72.         Debug.Print "  Min = (" & vOutline(nNumView)(0) * 1000# & ", " & vOutline(nNumView)(1) * 1000# & ") mm"
    
73.         Debug.Print "  Max = (" & vOutline(nNumView)(2) * 1000# & ", " & vOutline(nNumView)(3) * 1000# & ") mm"
    
74. 
    
75.         nNumView = nNumView + 1
    
76.       
    
77.         Set swView = swView.GetNextView
    
78.     Loop
    
79.    
    
80.     ' sheet 图纸1
    
81.     Set swView = swDraw.GetFirstView
    
82.   
    
83.     ' View 1 工程图视图1
    
84.     Set swView = swView.GetNextView
    
85.    
    
86.     'View 2 - vertically aligned to view 1 工程图视图2 (俯视图)垂直对齐于工程图视图1
    
87.     Set swView = swView.GetNextView
    
88.     vPos(2)(1) = vPos(1)(1) - (vPos(1)(1) - vOutline(1)(1)) - (vOutline(2)(3) - vPos(2)(1))   'Y座标修改
    
89.     swView.Position = vPos(2)
    
90.     swDraw.GraphicsRedraw2
    
91.     vPos(2) = swView.Position
    
92.     vOutline(2) = swView.GetOutline
    
93.    
    
94.     'View 3 - horizontally aligned to view 1 工程图视图3 (左视图)水平对齐于工程图视图1
    
95.     Set swView = swView.GetNextView
    
96.     vPos(3)(0) = vPos(1)(0) + (vOutline(1)(2) - vPos(1)(0)) + (vPos(3)(0) - vOutline(3)(0))   'X座标修改
    
97.     swView.Position = vPos(3)
    
98.     swDraw.GraphicsRedraw2
    
99.     vPos(3) = swView.Position
    
100.     vOutline(3) = swView.GetOutline
     
101.      
     
102.     'View 4 - vertically aligned to view 1  工程图视图4 (仰视图)垂直对齐于工程图视图1
     
103.     Set swView = swView.GetNextView
     
104.     vPos(4)(1) = vPos(1)(1) + (vOutline(1)(3) - vPos(1)(1)) + (vPos(4)(1) - vOutline(4)(1)) 'Y座标修改
     
105.     swView.Position = vPos(4)
     
106.     swDraw.GraphicsRedraw2
     
107.     vPos(4) = swView.Position
     
108.     vOutline(4) = swView.GetOutline
     
109.    
     
110.     'View 5 - horizontally aligned to view 1 工程图视图5 (右视图)水平对齐于工程图视图1
     
111.     Set swView = swView.GetNextView
     
112.     vPos(5)(0) = vPos(1)(0) - (vPos(1)(0) - vOutline(1)(0)) - (vOutline(5)(2) - vPos(5)(0))   'X座标修改
     
113.     swView.Position = vPos(5)
     
114.     swDraw.GraphicsRedraw2
     
115.      vPos(5) = swView.Position
     
116.      vOutline(5) = swView.GetOutline
     
117.    
     
118.     'View 6 - horizontally aligned to view 3 工程图视图3 (后视图)水平对齐于工程图视图3
     
119.     Set swView = swView.GetNextView
     
120.     vPos(6)(0) = vPos(3)(0) + (vOutline(3)(2) - vPos(3)(0)) + (vPos(6)(0) - vOutline(6)(0))  'X座标修改
     
121.     swView.Position = vPos(6)
     
122.     swDraw.GraphicsRedraw2
     
123.       vOutline(6) = swView.GetOutline
     
124.    
     
125.       
     
126.       'View 7 - horizontally aligned to view 1 工程图视图7 (左下轴测视图)
     
127.     Set swView = swView.GetNextView
     
128. 
     
129.      vPos(7)(0) = vPos(1)(0) + (vOutline(1)(2) - vPos(1)(0)) + (vPos(7)(0) - vOutline(7)(0))  'X座标修改相对于工程图视图1
     
130.     vPos(7)(1) = vPos(1)(1) - (vPos(1)(1) - vOutline(1)(1)) - (vOutline(7)(3) - vPos(7)(1))   'Y座标修改相对于工程图视图1
     
131.     swView.Position = vPos(7)
     
132.     swDraw.GraphicsRedraw2
     
133.     vOutline(7) = swView.GetOutline
     
134. 
     
135.     'View 8 - horizontally aligned to view 1 工程图视图8 (右下轴测视图)
     
136. 
     
137.     Set swView = swView.GetNextView
     
138. 
     
139.      vPos(8)(0) = vPos(1)(0) - (vPos(1)(0) - vOutline(1)(0)) - (vOutline(8)(2) - vPos(8)(0))  'X座标修改相对于工程图视图1
     
140.    vPos(8)(1) = vPos(1)(1) - (vPos(1)(1) - vOutline(1)(1)) - (vOutline(8)(3) - vPos(8)(1))   'Y座标修改相对于工程图视图1
     
141.    swView.Position = vPos(8)
     
142.      swDraw.GraphicsRedraw2
     
143.      vOutline(8) = swView.GetOutline
     
144.    
     
145. 
     
146.     'View 9 - horizontally aligned to view 1 工程图视图7 (左上轴测视图)
     
147. 
     
148.     Set swView = swView.GetNextView
     
149. 
     
150.      vPos(9)(0) = vPos(1)(0) + (vOutline(1)(2) - vPos(1)(0)) + (vPos(9)(0) - vOutline(9)(0))  'X座标修改相对于工程图视图1
     
151.     vPos(9)(1) = vPos(1)(1) + (vOutline(1)(3) - vPos(1)(1)) + (vPos(9)(1) - vOutline(9)(1))   'Y座标修改相对于工程图视图1
     
152.     swView.Position = vPos(9)
     
153.      swDraw.GraphicsRedraw2
     
154.      vOutline(9) = swView.GetOutline
     
155.    
     
156. 
     
157.     'View 10 - horizontally aligned to view 1 工程图视图8 (右上轴测视图)
     
158. 
     
159.     Set swView = swView.GetNextView
     
160. 
     
161.     vPos(10)(0) = vPos(1)(0) - (vPos(1)(0) - vOutline(1)(0)) - (vOutline(10)(2) - vPos(10)(0))  'X座标修改相对于工程图视图1
     
162.     vPos(10)(1) = vPos(1)(1) + (vOutline(1)(3) - vPos(1)(1)) + (vPos(10)(1) - vOutline(10)(1))   'Y座标修改相对于工程图视图1
     
163.     swView.Position = vPos(10)
     
164.     swDraw.GraphicsRedraw2
     
165.     vOutline(10) = swView.GetOutline
     
166. swDraw.ViewZoomtofit2
     
167. swDraw.ClearSelection2 (True)
     
168. 
     
169. 
     
170. '以下删除视图中产生的中心线
     
171. box(0) = vOutline(8)(0)
     
172. If vOutline(5)(0) < box(0) Then box(0) = vOutline(5)(0)
     
173. If vOutline(10)(0) < box(0) Then box(0) = vOutline(10)(0)
     
174. 
     
175. box(1) = vOutline(8)(1)
     
176. If vOutline(2)(1) < box(1) Then box(1) = vOutline(2)(1)
     
177. If vOutline(7)(1) < box(1) Then box(1) = vOutline(7)(1)
     
178. 
     
179. box(2) = vOutline(9)(2)
     
180. If vOutline(6)(2) > box(2) Then box(2) = vOutline(6)(2)
     
181. If vOutline(7)(2) > box(2) Then box(2) = vOutline(7)(2)
     
182. 
     
183. box(3) = vOutline(9)(3)
     
184. If vOutline(4)(3) > box(3) Then box(3) = vOutline(4)(3)
     
185. If vOutline(10)(3) > box(3) Then box(3) = vOutline(10)(3)
     
186. 
     
187. 
     
188. boolstatus = swApp.SetSelectionFilter(swSelCENTERLINES, True)    '过滤选择中心线
     
189. boolstatus = swDraw.ActivateSheet("图纸1")
     
190. boolstatus = swDraw.Extension.SketchBoxSelect(box(0), box(1), "0.000000", box(2), box(3), "0.000000")   '框选
     
191. swDraw.EditDelete   '删除中心线
     
192. 
     
193. boolstatus = swApp.SetSelectionFilter(swSelCENTERLINES, False)   '取消过滤选择中心线
     
194. 
     
195. swModelName = Left(swModelName, Len(swModelName) - 7) + "(6+4).slddrw"  '定义工程图名
     
196. 
     
197. longstatus = swDraw.SaveAs3(swModelName, 0, 0) '存为工程图文件
     
198. 
     
199. swModelName = Left(swModelName, Len(swModelName) - 6) + "dwg"    '定义工程图名
     
200. 
     
201. longstatus = swDraw.SaveAs3(swModelName, 0, 0) '存为DWG文件
     
202. 
     
203. End Sub
     

复制代码

谢谢分享

多谢楼主

多谢楼主

怎么替换工程图模板?

请问怎么替换工程图模板呢?

先下载来，以后备用

谢谢分享，回帖学习

212312121111111111