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

' ******************************************************************************
' autodraw.swp - By PYCZT, Copyright 2016-2018 writed on 06/28/16
' Notes: Templatesfile must be in same directory as macro file 注意:工程图6+4.DRWDOT模板文件与宏文件同目录
'条件:当前开启零件或装配图
'结果:自动建立带有6个标准视图和4个轴测视图的工程图文件,并保存和另存为同名加后缀6+4的DWG文件
'如在模型图中更新前视视图,则得到理想的主视图,得到理想的DWG
'******************************************************************************
Dim swApp As Object
Dim swModel As Object
Dim swDraw As Object
Dim swModelName As String
Dim Templatesfile As String
Dim boolstatus As Boolean
Dim swView As Object
Dim vOutline() As Variant
Dim vPos() As Variant
Dim nNumView As Long
Dim box(3) As Single
Dim longstatus As Long, longwarnings As Long
Sub main()
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc
swModelName = swModel.GetPathName '读取当前SW模型文档名(含路径)
Templatesfile = swApp.GetCurrentMacroPathName ' Get macro path+filename 取得宏路径和名称
Templatesfile = Left$(Templatesfile, Len(Templatesfile) - 12) + "工程图6+4.DRWDOT" ' Set Templates file name 设工程图模板名称
Set swDraw = swApp.NewDocument(Templatesfile, 0, 0, 0) '以模板建立工程图
boolstatus = swDraw.InsertModelInPredefinedView(swModelName) '在工程图中插入当前的模型
'四个轴测图取消对齐关系(重新定位)
boolstatus = swDraw.ActivateView("工程图视图7")
boolstatus = swDraw.Extension.SelectByID2("工程图视图7", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
boolstatus = swView.RemoveAlignment
boolstatus = swDraw.ActivateView("工程图视图8")
boolstatus = swDraw.Extension.SelectByID2("工程图视图8", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
boolstatus = swView.RemoveAlignment
boolstatus = swDraw.ActivateView("工程图视图9")
boolstatus = swDraw.Extension.SelectByID2("工程图视图9", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
boolstatus = swView.RemoveAlignment
boolstatus = swDraw.Extension.SelectByID2("工程图视图10", "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0)
Set swView = swDraw.SelectionManager.GetSelectedObject5(1)
boolstatus = swView.RemoveAlignment
swDraw.ClearSelection2 True
'Drawing views are repositioned so that none of them overlap.以下重新定位视图以免重叠
nNumView = 0
Set swView = swDraw.GetFirstView
Do While Not swView Is Nothing
ReDim Preserve vOutline(nNumView)
ReDim Preserve vPos(nNumView)
vOutline(nNumView) = swView.GetOutline
vPos(nNumView) = swView.Position
Debug.Print "View = " + swView.GetName2
Debug.Print " Pos = (" & vPos(nNumView)(0) * 1000# & ", " & vPos(nNumView)(1) * 1000# & ") mm"
Debug.Print " Min = (" & vOutline(nNumView)(0) * 1000# & ", " & vOutline(nNumView)(1) * 1000# & ") mm"
Debug.Print " Max = (" & vOutline(nNumView)(2) * 1000# & ", " & vOutline(nNumView)(3) * 1000# & ") mm"
nNumView = nNumView + 1
Set swView = swView.GetNextView
Loop
' sheet 图纸1
Set swView = swDraw.GetFirstView
' View 1 工程图视图1
Set swView = swView.GetNextView
'View 2 - vertically aligned to view 1 工程图视图2 (俯视图)垂直对齐于工程图视图1
Set swView = swView.GetNextView
vPos(2)(1) = vPos(1)(1) - (vPos(1)(1) - vOutline(1)(1)) - (vOutline(2)(3) - vPos(2)(1)) 'Y座标修改
swView.Position = vPos(2)
swDraw.GraphicsRedraw2
vPos(2) = swView.Position
vOutline(2) = swView.GetOutline
'View 3 - horizontally aligned to view 1 工程图视图3 (左视图)水平对齐于工程图视图1
Set swView = swView.GetNextView
vPos(3)(0) = vPos(1)(0) + (vOutline(1)(2) - vPos(1)(0)) + (vPos(3)(0) - vOutline(3)(0)) 'X座标修改
swView.Position = vPos(3)
swDraw.GraphicsRedraw2
vPos(3) = swView.Position
vOutline(3) = swView.GetOutline
'View 4 - vertically aligned to view 1 工程图视图4 (仰视图)垂直对齐于工程图视图1
Set swView = swView.GetNextView
vPos(4)(1) = vPos(1)(1) + (vOutline(1)(3) - vPos(1)(1)) + (vPos(4)(1) - vOutline(4)(1)) 'Y座标修改
swView.Position = vPos(4)
swDraw.GraphicsRedraw2
vPos(4) = swView.Position
vOutline(4) = swView.GetOutline
'View 5 - horizontally aligned to view 1 工程图视图5 (右视图)水平对齐于工程图视图1
Set swView = swView.GetNextView
vPos(5)(0) = vPos(1)(0) - (vPos(1)(0) - vOutline(1)(0)) - (vOutline(5)(2) - vPos(5)(0)) 'X座标修改
swView.Position = vPos(5)
swDraw.GraphicsRedraw2
vPos(5) = swView.Position
vOutline(5) = swView.GetOutline
'View 6 - horizontally aligned to view 3 工程图视图3 (后视图)水平对齐于工程图视图3
Set swView = swView.GetNextView
vPos(6)(0) = vPos(3)(0) + (vOutline(3)(2) - vPos(3)(0)) + (vPos(6)(0) - vOutline(6)(0)) 'X座标修改
swView.Position = vPos(6)
swDraw.GraphicsRedraw2
vOutline(6) = swView.GetOutline
'View 7 - horizontally aligned to view 1 工程图视图7 (左下轴测视图)
Set swView = swView.GetNextView
vPos(7)(0) = vPos(1)(0) + (vOutline(1)(2) - vPos(1)(0)) + (vPos(7)(0) - vOutline(7)(0)) 'X座标修改相对于工程图视图1
vPos(7)(1) = vPos(1)(1) - (vPos(1)(1) - vOutline(1)(1)) - (vOutline(7)(3) - vPos(7)(1)) 'Y座标修改相对于工程图视图1
swView.Position = vPos(7)
swDraw.GraphicsRedraw2
vOutline(7) = swView.GetOutline
'View 8 - horizontally aligned to view 1 工程图视图8 (右下轴测视图)
Set swView = swView.GetNextView
vPos(8)(0) = vPos(1)(0) - (vPos(1)(0) - vOutline(1)(0)) - (vOutline(8)(2) - vPos(8)(0)) 'X座标修改相对于工程图视图1
vPos(8)(1) = vPos(1)(1) - (vPos(1)(1) - vOutline(1)(1)) - (vOutline(8)(3) - vPos(8)(1)) 'Y座标修改相对于工程图视图1
swView.Position = vPos(8)
swDraw.GraphicsRedraw2
vOutline(8) = swView.GetOutline
'View 9 - horizontally aligned to view 1 工程图视图7 (左上轴测视图)
Set swView = swView.GetNextView
vPos(9)(0) = vPos(1)(0) + (vOutline(1)(2) - vPos(1)(0)) + (vPos(9)(0) - vOutline(9)(0)) 'X座标修改相对于工程图视图1
vPos(9)(1) = vPos(1)(1) + (vOutline(1)(3) - vPos(1)(1)) + (vPos(9)(1) - vOutline(9)(1)) 'Y座标修改相对于工程图视图1
swView.Position = vPos(9)
swDraw.GraphicsRedraw2
vOutline(9) = swView.GetOutline
'View 10 - horizontally aligned to view 1 工程图视图8 (右上轴测视图)
Set swView = swView.GetNextView
vPos(10)(0) = vPos(1)(0) - (vPos(1)(0) - vOutline(1)(0)) - (vOutline(10)(2) - vPos(10)(0)) 'X座标修改相对于工程图视图1
vPos(10)(1) = vPos(1)(1) + (vOutline(1)(3) - vPos(1)(1)) + (vPos(10)(1) - vOutline(10)(1)) 'Y座标修改相对于工程图视图1
swView.Position = vPos(10)
swDraw.GraphicsRedraw2
vOutline(10) = swView.GetOutline
swDraw.ViewZoomtofit2
swDraw.ClearSelection2 (True)
'以下删除视图中产生的中心线
box(0) = vOutline(8)(0)
If vOutline(5)(0) < box(0) Then box(0) = vOutline(5)(0)
If vOutline(10)(0) < box(0) Then box(0) = vOutline(10)(0)
box(1) = vOutline(8)(1)
If vOutline(2)(1) < box(1) Then box(1) = vOutline(2)(1)
If vOutline(7)(1) < box(1) Then box(1) = vOutline(7)(1)
box(2) = vOutline(9)(2)
If vOutline(6)(2) > box(2) Then box(2) = vOutline(6)(2)
If vOutline(7)(2) > box(2) Then box(2) = vOutline(7)(2)
box(3) = vOutline(9)(3)
If vOutline(4)(3) > box(3) Then box(3) = vOutline(4)(3)
If vOutline(10)(3) > box(3) Then box(3) = vOutline(10)(3)
boolstatus = swApp.SetSelectionFilter(swSelCENTERLINES, True) '过滤选择中心线
boolstatus = swDraw.ActivateSheet("图纸1")
boolstatus = swDraw.Extension.SketchBoxSelect(box(0), box(1), "0.000000", box(2), box(3), "0.000000") '框选
swDraw.EditDelete '删除中心线
boolstatus = swApp.SetSelectionFilter(swSelCENTERLINES, False) '取消过滤选择中心线
swModelName = Left(swModelName, Len(swModelName) - 7) + "(6+4).slddrw" '定义工程图名
longstatus = swDraw.SaveAs3(swModelName, 0, 0) '存为工程图文件
swModelName = Left(swModelName, Len(swModelName) - 6) + "dwg" '定义工程图名
longstatus = swDraw.SaveAs3(swModelName, 0, 0) '存为DWG文件
End Sub

复制代码