SolidWorks根据装配体生成工程图的宏程序资料

在网上看到的：在WIN7 SW2014下现在不能用，看看改了能用不？烦请懂的人指点下，并将文件上传到群里来：

SolidWorks 生成工程图纸程序

下面代码是工程图助手中的“生成工程图”模块内容。它按照我们的图纸存储规范，把一个产品的每个装配体都生成一个solidworks的工程图文件。

面对一个问题，我们在试图使用VBA来改善工作的时候，可以参考下面的思路来进行，当然，这也只是个人的一些经验之说，并不是最好的工作方式：首先我们需要了解实际工作情况，发现问题所在：工艺人员在试图提高solidworks工作效率的时候提到了使用SolidWorks Task Scheduler来自动出图纸的方法（具体方法就不讨论了）。大家经过一段时间的使用后发现，使用SolidWorks Task Scheduler有一定的局限性，需要问题在于，它将每个solidworks文件—包括零件、装配体—都生成了一个工程图文件。然而这样得到的结果便是一个零部件稍多的产品，将会自动生成很多的工程图文件，不便于管理。我们的习惯是，按照装配体来出图纸，将一个装配体中的零部件在一个工程图文件中表示。这样表达清楚而且便于管理。恩，这就是现实的问题所在。

然后，我们要考虑可行性：思考了SolidWorks Task Scheduler的实现，发现使用VBA在技术方面可以实现此类功能，并且有一定的规律可以遵守而不需要太多的人为判断就可以达到要求。这里插一句，在使用SolidWorks Task Scheduler时我发现了一个选项：备份任务文件，而这个任务文件上所记录的正式一段使用VBA写的宏代码。

接下来，需要现场调研确定需求目标：在了解了solidworks使用相应的规范和工艺员在实际工作中的要求后我们对问题目标有了一个比较明确的概念。我们要做的项目需要完成这样的工作：它针对一个产品中的每个装配体生成一个工作图文件，每本工程图文件中需要一张装配体的三视图和其每个子零件的三视图图纸。并将它们存储在和“图纸”文件夹（存放solidworks模型）同级的目录下的“工程图”文件夹里。

做好了准备工作，即可开始写程序。将需求的内容转化成软件问题描述，并描述其大致方法：

1、得到产品文件的每个装配体：我们可以通过文件夹中文件的遍历，按照后缀名“.sldasm”来得到一个目录下所有的装配体；也可以通过遍历一个产品总装配体的组件来得到每一个子装配体模型。实际的编码中我们选择了后者，因为它虽然给编写代码结构带来了复杂度，但是正确性和稳定性都要好过前者。装配体的组件是一个树型结构，使用递归式是比较灵活的方法，前面章节也已经介绍过。

2、生成工程图并插入零件的模型三视图：SolidWorks Task Scheduler使用预定义的模型视图来完成自动生成的功能，但是，一旦需要在原有的图纸上插入新图纸时，就不能够继承图纸模版的预定义试图了。所以需要使用CreateDrawViewFromModelView2和CreateUnfoldedViewAt3来替代。

一切准备完毕后就可以设计程序框架进行编码了：这里定义了三个过程，main、traverseasm、createdraw。它们的定义和完成的作用如下：Main（）：模块主函数没有参数和返回值，它得到当前打开装配体的路径、设置“工程图文件夹路径”、运行traverseasm过程。

Traverseasm(filepath as string):此过程接受一个装配体的存储路径字符串参数，完成装配体的递归遍历工作，得到每一个装配体，并让每一个装配体都作为参数运行createdraw过程。

Createdraw(filepath as string): 此过程接受一个装配体的存储路径字符串参数，生成此装配体的工程图。

'/************************************************************

'drawcreator ：根据装配体生成工程图

'main:

' get opened asm model infomation:

' filepathname

' drawpathname

' make dir path is drawpathname

' call traverseasm with argument filepathname'

'traverseasm:

' for itself call createdraw with argument itself

' traverse the asm model component

' for each sub asm model:

' call traverseasm'

'createdraw:

' create a drawdoc with given DrawTemplate

' insert each sub part model component a sheet

'

'************************************************************/ Option Explicit

'定义部分：

Dim SwApp As SldWorks.SldWorks

Dim DrawPathName As String

Dim File As String

Dim nErrors As Long

Dim nWarnings As Long

Dim StatofanNo As Boolean

Dim Pos As Integer

'/******************

'sub main goes here:

'*******************

Sub Main()

On Error Resume Next

Dim ActModel As SldWorks.ModelDoc2

Dim YesOrNo As VbMsgBoxResult

Set SwApp = CreateObject("SldWorks.Application")

Set ActModel = SwApp.ActiveDoc

If ActModel Is Nothing Then

MsgBox "请先打开装配体"

End If

'得到装配体文件路径

File = ActModel.GetPathName

'得到工程图保存路径

DrawPathName = Left(File, InStrRev(File, "\") - 1)

DrawPathName = Left(DrawPathName, InStrRev(DrawPathName, "\"))

DrawPathName = DrawPathName + "工程图\"

'创建文件夹

MkDir (DrawPathName)

'调试信息 :

Debug.Print DrawPathName

Debug.Print File

'should i set all object nothing ?

Set ActModel = Nothing

Set SwApp = Nothing

YesOrNo = MsgBox("需要自动在零件工程图中插入模型项目么？", vbOKCancel, "提示")

If YesOrNo = vbOK Then

StatofanNo = True

Else

StatofanNo = False

End If

SwApp.Visible = False

'调用函数遍历装配体组件

TraverseAsm File

SwApp.Visible = True

End Sub

'/************************

'sub traverseasm goes here :

''*************************

Sub TraverseAsm(FilePath As String) 'Traverse Asm 遍历ASM文件

Dim SwModel2 As SldWorks.ModelDoc2

Dim SwConf2 As SldWorks.Configuration

Dim SwRootComp2 As https://www.360docs.net/doc/b8613520.html,ponent2

Dim SwChildComp2 As https://www.360docs.net/doc/b8613520.html,ponent2

Dim vChildComp2 As Variant

Dim FileType2 As String

Dim n As Long

Set SwApp = CreateObject("SldWorks.Application")

If SwApp Is Nothing Then

MsgBox "创建SW对象失败"

Exit Sub

End If

Set SwModel2 = SwApp.OpenDoc6(FilePath, 2, 0, "", nErrors, nWarnings) 'file open good

If SwModel2 Is Nothing Then

MsgBox "加载装配体失败"

Exit Sub

End If

Set SwConf2 = SwModel2.GetActiveConfiguration 'need to change SwModel to traverse

Set SwRootComp2 = SwConf2.GetRootComponent

vChildComp2 = SwRootComp2.GetChildren

For n = 0 To UBound(vChildComp2)

Set SwChildComp2 = vChildComp2(n)

FileType2 = UCase(Right(SwChildComp2.GetPathName, 6))

If FileType2 = "SLDASM" Then

TraverseAsm SwChildComp2.GetPathName

End If

Next

Debug.Print SwModel2.GetPathName

If Not Mid(SwModel2.GetTitle, 1, 2) = "镜向" Then

CreateDraw SwModel2.GetPathName

End If

End Sub

'/**************************************************

'sub createdraw goes here :

'**************************************************/

Sub CreateDraw(FilePath As String)

Dim SwModel As SldWorks.ModelDoc2

Dim SwSave As SldWorks.ModelDoc2

Dim SwDraw As SldWorks.DrawingDoc

Dim SwChildComp As https://www.360docs.net/doc/b8613520.html,ponent2

Dim SwChildCmp2 As https://www.360docs.net/doc/b8613520.html,ponent2

Dim SwConf As SldWorks.Configuration

Dim SwRootComp As https://www.360docs.net/doc/b8613520.html,ponent2

Dim CurSheet As SldWorks.Sheet

Dim SwView As SldWorks.View

Dim vChildComp As Variant

Dim SheetArr As String

Dim SpadStr As String

Dim AsmFile As String

Dim DrawFiel As String

Dim DrawDir As String

Dim DrawTemp As String

Dim DeString As String

Dim tmpString As String

Dim sTmpStr As String

Dim FileType As String

Dim SheetName As String

Dim ViewName As String

Dim sFileName As String

Dim File As String

Dim i As Long

Dim isOk As Boolean

Dim wGood As Integer

AsmFile = FilePath

DrawDir = DrawPathName

'for easy to use i specified a template file

DrawTemp = SwApp.GetExecutablePath &

"\lang\chinese-simplified\Tutorial\auto.DRWDOT"

SheetArr = "ardenmakeastupidwaybutrunsok"

Set SwApp = CreateObject("SldWorks.Application")

If SwApp Is Nothing Then

MsgBox "创建SW对象失败"

Exit Sub

End If

Set SwModel = SwApp.OpenDoc6(AsmFile, 2, 0, "", nErrors, nWarnings) If SwModel Is Nothing Then

MsgBox "打开装配体失败"

Exit Sub

End If

SwModel.EditRebuild3

'创建drawdoc文档

Debug.Print DrawTemp

Set SwDraw = SwApp.NewDocument(DrawTemp, 2, 0.2, 0.4)

If SwDraw Is Nothing Then

MsgBox "创建工程图失败"

Exit Sub

End If

Set CurSheet = SwDraw.GetCurrentSheet

'插入模型到预定义视图

isOk = SwDraw.InsertModelInPredefinedView(AsmFile)

If isOk = False Then

MsgBox "插入装配体三视图失败"

End If

DeString = SwModel.GetTitle

tmpString = Left(DeString, InStrRev(DeString, ".") - 1)

If InStrRev(tmpString, " ", -1, vbTextCompare) <= 0 Then

DeString = tmpString

' notice : need to write more to modify it

Else

DeString = Replace(tmpString, Left(tmpString, InStrRev(tmpString, " ") - 1), "")

End If

'sheet名称设定规则：模型名称（不包括物料编码）+三视图

CurSheet.SetName (DeString + "三视图")

Set SwView = SwDraw.GetFirstView

https://www.360docs.net/doc/b8613520.html,eSheetScale = True '设置为图纸比例 does it works right？

''debug.print https://www.360docs.net/doc/b8613520.html,eSheetScale

'''debug.print "the sheet name is : " & destring + "三视图"

'save draw file but do not open it

wGood = SwModel.SaveAs2(DrawDir + tmpString + ".SLDDRW", 0, False, True)

'''debug.print "save asm draw file state:" & wgood

'''debug.print DrawDir & "\" & tmpstring & ".SLDDRW"

If wGood = 0 Then

MsgBox "保存三视图失败"

End If

'>>>

'怎样才能不覆盖保存？

'then traverse all part file next level insert sheet on this draw '已经将装配体的三视图插入draw文件了

'要遍历装配体：part部分

'SwApp.ActivateDoc2 SwModel.GetPathName, True, nErrors

Set SwConf = SwModel.GetActiveConfiguration 'need to change SwModel to traverse

'''debug.print "activeconfiguration is :" & https://www.360docs.net/doc/b8613520.html,

Set SwRootComp = SwConf.GetRootComponent

'''debug.print "rootcompoent is :" & https://www.360docs.net/doc/b8613520.html,

vChildComp = SwRootComp.GetChildren

'开始对装配体下一层组建进行遍历，忽略子装配体，只将本身和子零件出图-'

'begin loop-

'

For i = 0 To UBound(vChildComp)

'''debug.print "enter loop 0 to " & UBound(vChildComp)

Set SwChildComp = vChildComp(i)

'-

If i < UBound(vChildComp) Then

Set SwChildCmp2 = vChildComp(i + 1)

Else

Set SwChildCmp2 = vChildComp(0)

End If

'''debug.print "sub comp " & i & " name is : " & https://www.360docs.net/doc/b8613520.html, FileType = UCase(Right(SwChildComp.GetPathName, 6))

If FileType = "SLDPRT" Then ' 如果是零件，插入图纸

If SwDraw Is Nothing Then

'''debug.print "SwDraw is nothing"

Else

'''debug.print "SwDraw has :" & SwDraw.GetSheetCount & "sheets"

End If

''// 得到图纸名称

sTmpStr = SwChildComp.GetPathName

''debug.print "1: " & stmpstr

sTmpStr = Left(sTmpStr, InStrRev(sTmpStr, ".") - 1)

''debug.print "2: " & stmpstr

sTmpStr = Right(sTmpStr, Len(sTmpStr) - InStrRev(sTmpStr, "\")) ''debug.print "3: " & stmpstr

If InStr(sTmpStr, " ") <= 0 Then

SheetName = LTrim(sTmpStr)

Else

SheetName = LTrim(Replace(sTmpStr, Left(sTmpStr,

InStrRev(sTmpStr, " ") - 1), ""))

End If

' 得到图纸名称//

Debug.Print "sheetname:" & SheetName

Debug.Print "SheetArr" & SheetArr

' 忽略镜像零部件

If Not Mid(SheetName, 1, 2) = "镜向" Then

'//-如果重复跳过If Not SwChildComp.GetPathName =

SwChildCmp2.GetPathName Then

'//-也是判断有没有这个表

If InStr(1, SheetArr, SheetName, vbTextCompare) = 0 Then

' If Not InStrRev(1, SheetArr, sheetname, vbTextCompare) = 0 Then

SwDraw.NewSheet3 SheetName, 12, 12, 1#, 10#, True, "美克A4横.slddrt", 2, 2, ""

SheetArr = SheetArr & SheetName

Debug.Print "add" & SheetArr

SwDraw.ActivateSheet SheetName

Set CurSheet = SwDraw.GetCurrentSheet

CurSheet.SheetFormatVisible = True

'CurSheet.SetTemplateName DrawTemp

'''debug.print "part fullname is :" & SwChildComp.GetPathName

'SwDraw.InsertModelInPredefinedView SwChildComp.GetPathName

'//- 创建三视图-

Set SwView =

SwDraw.CreateDrawViewFromModelView2(SwChildComp.GetPathName, "*前视", 0.07954434782609, 0.09376565217391, 0)

'''debug.print "viewname is :" & https://www.360docs.net/doc/b8613520.html,

ViewName = https://www.360docs.net/doc/b8613520.html,

'''debug.print "SwView name is :" & viewname

SwDraw.Extension.SelectByID2 ViewName, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0

SwDraw.ActivateView ViewName

Set SwView = SwDraw.CreateUnfoldedViewAt3(0.2224917391304,

0.09376565217391, 0, 0) '上视

SwDraw.ClearSelection2 True

SwDraw.Extension.SelectByID2 ViewName, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0

Set SwView = SwDraw.CreateUnfoldedViewAt3(0.07954434782609, 0.1534239130435, 0, 0) '右视

SwDraw.ClearSelection2 True

SwDraw.Extension.SelectByID2 ViewName, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0

Set SwView = SwDraw.CreateUnfoldedViewAt3(0.1636082608696,

0.1778295652174, 0, 0) '斜视

SwDraw.ClearSelection2 True

'SwDraw.ActivateView viewname

'SwDraw.Extension.SelectByID2 SwView.GetName2, "DRAWINGVIEW", 0, 0, 0, False, 0, Nothing, 0

If Not SwView Is Nothing Then

''debug.print "SwView name : " & SwView.GetName2

SwView.SetDisplayMode3 False, 3, False, True ' 隐藏线可见

''debug.print "scale : " & SwView.ScaleRatio(1)

Else

''debug.print "SwView is nothing "

End If

If StatofanNo = True Then

'insert annotation

SwDraw.InsertModelAnnotations3 0, 1605656, True, True, False, False '斜视图为带边线上色

Else

'donothing

End If

' 创建三视图//

End If

'//-也是判断有没有这个表

End If

'//如果重复跳过-

End If

'End If

SwDraw.ForceRebuild3 False

Next i '

'-end loop

SwDraw.ForceRebuild3 False

Set SwSave = SwDraw

'isok = SwSave.SaveAs4(SwSave.GetTitle, 0, 0, nErrors, nWarnings) sFileName = DrawDir + tmpString + ".SLDDRW"

isOk = SwSave.SaveAs2(sFileName, 0, False, True)

'''debug.print "save " & sfilename & " state : " & isok

If isOk = False Then

''debug.print "保存" & sfilename & "失败"

End If

SwApp.CloseDoc SwSave.GetTitle

Set SwDraw = Nothing

End Sub