前言

作为一名机械工程师，出图 / 导图时一件稀松平时的事情，但是导图上尤其会重复性地浪费时间，此时 SolidWorks 宏程序可以很好解决这个问题。下面我将使用 VBA 逐步讲一下这方面的编程，如果对 SolidWorks 宏一无所知的读者，建议先行搜索一下 SolidWorks VBA 相关方面的内容。

需求

我的需求是哪张图现在打开了或者鼠标选中的，那就把这张图二维图和三维图导出来。

实现思路

导图逻辑&实现思路
导图逻辑 & 实现思路

判断鼠标是否选中零部件

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
'施法前摇
Dim swApp As Object
Dim swModel As Object
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

'选择工具
Dim swSelMgr As SldWorks.SelectionMgr
Dim swSelComp As SldWorks.Component2
Set swSelMgr = swModel.SelectionManager
Set swSelComp = swSelMgr.GetSelectedObjectsComponent2(1)

'判断是否选择了零部件且当前模型为装配体
'注意多选的情况只会判断第一个
Dim swSelModel As SldWorks.ModelDoc2
Dim errors As Long
If swSelMgr.GetSelectedObjectType2(1) <> 0 And swModel.GetType = 2 Then
    '解除压缩
    swSelComp.SetSuppression2 (2)
    Set swSelModel = swSelComp.GetModelDoc2
    Set swModel = swApp.ActivateDoc2(swSelModel.GetTitle, True, errors)
End If

当前窗口是否为工程图

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
'施法前摇
Dim swApp As Object
Dim swModel As Object
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

Dim errors As Long
If swModel.GetType = 3 Then
    swModel.Save
    'IsFileExists()是另一个函数，FSO是引入的一个模块，下面都会讲
    '窗口切换到三维模型
    If IsFileExists(Replace(FileName, "SLDDRW", "SLDPRT")) Then
        Set swModel = swApp.ActivateDoc2(Replace(FSO.GetBaseName(FileName), "SLDDRW", "SLDPRT"), True, errors)
    Else
        Set swModel = swApp.ActivateDoc2(Replace(FSO.GetBaseName(FileName), "SLDDRW", "SLDASM"), True, errors)
    End If
    '弹出提示并退出程序
    swApp.SendMsgToUser "再运行以导图"
    Exit Sub
End If

获取文件属性

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
'施法前摇
Dim swApp As Object
Dim swModel As Object
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

'文件属性对象
Dim swModelDocExt As ModelDocExtension
Dim swCustProp As CustomPropertyManager
Set swModelDocExt = swModel.Extension
Set swCustProp = swModelDocExt.CustomPropertyManager("") '""为自定义属性；"name"为配置属性，name为配置名字

Dim bool As Boolean
Dim val As String
Dim version As String
Dim designer As String
'获取到的不是val，而是后面的变量
bool = swCustProp.Get4("version", False, val, version)
bool = swCustProp.Get4("designer", False, val, designer)

开始导图

三维模型

1
2
3
4
5
6
7
8
9
10
11
12
13
14
'施法前摇
Dim swApp As Object
Dim swModel As Object
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

Dim PartName As String
Dim newFilename As String
Dim Name As Variant
Dim longstatus As Long
PartName = swModel.GetTitle
Name = Split(PartName, ".")
newFilename = Name(0) & ".STEP"
longstatus = swModel.SaveAs3(newFilename, 0, 2)

二维图

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
'施法前摇
Dim swApp As Object
Dim swModel As Object
Set swApp = Application.SldWorks

'打开工程图
Dim Filename As String
Dim longwarnings As Long
Dim longstatus As Long
Set swModel = swApp.OpenDoc6(FileName, 3, 0, "", longstatus, longwarnings)

'若后台已打开
If longwarnings = 128 Or longstatus = 65536 Then
    Set swModel = swApp.ActivateDoc2(FileName, False, errors)
End If
swModel.ViewZoomtofit2

'输出PDF
Dim PartName As String
Dim newFilename As String
Dim Name As Variant
Dim longstatus As Long
PartName = swModel.GetTitle
Name = Split(PartName, ".")
newFilename = Name(0) & ".PDF"
longstatus = swModel.SaveAs3(newFilename, 0, 2)

保存并关闭文件

1
2
3
4
5
6
7
8
9
'施法前摇
Dim swApp As Object
Dim swModel As Object
Set swApp = Application.SldWorks
Set swModel = swApp.ActiveDoc

'保存后关闭
swModel.Save
swApp.CloseDoc swModel.GetTitle

引入的库与函数

FSO

这个库主要用来对文件名进行相关操作，详见 Excel VBA 操作文件（夹）神器–FSO 对象。

IsFileExists()

1
2
3
4
5
6
7
8
'检查文件是否存在
Function IsFileExists(ByVal strFileName As String) As Boolean
    If Dir(strFileName, 16) <> Empty Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function

为什么要打开扩展名

  • 利用文件后缀名，方便切换窗口（工程图→三维模型→工程图）。
  • 便于指定导出的文件类型。

如果之前电脑没有打开文件后缀名，打开后需要重启 SolidWorks。

1
2
3
4
5
6
7
'判断是否勾选文件扩展名
If InStr(UCase(swModel.GetTitle), ".SLD") = 0 Then
    swApp.SendMsgToUser "请勾选文件扩展名后重新打开SolidWorks再运行" & Chr(10) & "“此电脑-查看-显示/隐藏-文件扩展名”"
    Shell "explorer.exe"
    swPrgBar.End
    Exit Sub
End If

附：完整代码

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
Dim swApp As Object
Dim swModel As Object
Dim swModelDocExt As ModelDocExtension
Dim swSelMgr As SldWorks.SelectionMgr
Dim swSelComp As SldWorks.Component2
Dim swSelModel As SldWorks.ModelDoc2
Dim swCustProp As CustomPropertyManager
Dim swPrgBar As SldWorks.UserProgressBar
Dim errors As Long
Dim longwarnings As Long
Dim longstatus As Long
Dim newFilename As String
Dim bool As Boolean
Dim version As String
Dim designer As String
Dim val As String
Dim model_save_by As String
Dim drawing_save_by As String

Sub main()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set swApp = Application.SldWorks
    Set swModel = swApp.ActiveDoc
    PartName = swModel.GetTitle
    swApp.GetUserProgressBar swPrgBar
    swPrgBar.Start 0, 100, "开始导图"
    swPrgBar.UpdateProgress 10

    '判断是否选择零件
    Set swSelMgr = swModel.SelectionManager
    Set swSelComp = swSelMgr.GetSelectedObjectsComponent2(1)
    If swSelMgr.GetSelectedObjectType2(1) <> 0 And swModel.GetType = 2 Then
        swSelComp.SetSuppression2 (2)
        Set swSelModel = swSelComp.GetModelDoc2
        Set swModel = swApp.ActivateDoc2(swSelModel.GetTitle, True, errors)
        swPrgBar.UpdateTitle "你选择了" & swSelModel.GetTitle
        swPrgBar.UpdateProgress 15
        isAsm = True
    End If

    '导出的文件路径
    FileName = swModel.GetPathName()
    FilePath = FSO.GetParentFolderName(FileName)
    swPrgBar.UpdateProgress 20

    '判断打开的是否为工程图
    If swModel.GetType = 3 Then
        swModel.Save
        If IsFileExists(Replace(FileName, "SLDDRW", "SLDPRT")) Then
            Set swModel = swApp.ActivateDoc2(Replace(FSO.GetBaseName(FileName), "SLDDRW", "SLDPRT"), True, errors)
        Else
            Set swModel = swApp.ActivateDoc2(Replace(FSO.GetBaseName(FileName), "SLDDRW", "SLDASM"), True, errors)
        End If
        swApp.SendMsgToUser "再运行以导图"
        swPrgBar.End
        Exit Sub
    End If

    PartName = swModel.GetTitle
    swModel.ClearSelection2 True
    swModel.ViewZoomtofit2
    swPrgBar.UpdateTitle "模型已打开"
    swPrgBar.UpdateProgress 30

    '获取版本&设计
    Set swModelDocExt = swModel.Extension
    Set swCustProp = swModelDocExt.CustomPropertyManager("")
    bool = swCustProp.Get4("version", False, val, version)
    bool = swCustProp.Get4("designer", False, val, designer)
    '获取画图的人
    model_save_by = swModel.SummaryInfo(swSummInfoField_e.swSumInfoSavedBy)
    Name = Split(PartName, ".")
    swPrgBar.UpdateTitle "模型版本和设计已获取"
    swPrgBar.UpdateProgress 40

    '判断是否勾选文件扩展名
    If InStr(UCase(PartName), ".SLD") = 0 Then
        swApp.SendMsgToUser "请勾选文件扩展名后重新打开SolidWorks再运行" & Chr(10) & "“此电脑-查看-显示/隐藏-文件扩展名”"
        Shell "explorer.exe"
        swPrgBar.End
        Exit Sub
    End If

    'STEP
    If swModel.GetType = 1 Then
        newFilename = Name(0) & "-" & version & ".STEP"
        longstatus = swModel.SaveAs3(newFilename, 0, 2)
        swPrgBar.UpdateTitle "STEP已生成"
    End If
    swPrgBar.UpdateProgress 50

    'PDF
    newFilename = Name(0) & "-" & version & ".PDF"
    '打开工程图
    Set swModel = swApp.OpenDoc6(Replace(FileName, FSO.GetExtensionName(PartName), "SLDDRW"), 3, 0, "", longstatus, longwarnings)
    '若后台已打开
    If longwarnings = 128 Or longstatus = 65536 Then
        Set swModel = swApp.ActivateDoc2(Replace(FileName, FSO.GetExtensionName(PartName), "SLDDRW"), False, errors)
    End If
    swModel.ViewZoomtofit2
    swPrgBar.UpdateProgress 60
    Set swModel = swApp.ActiveDoc
    Set swModelDocExt = swModel.Extension
    Set swCustProp = swModelDocExt.CustomPropertyManager("")
    drawing_save_by = swModel.SummaryInfo(swSummInfoField_e.swSumInfoSavedBy)
    '工程图改署名
    If model_save_by = drawing_save_by Then
        bool = swCustProp.Add3("drawer", 30, designer, 2)
    End If
    swModel.EditRebuild3
    longstatus = swModel.SaveAs3(newFilename, 0, 2)
    swPrgBar.UpdateTitle "PDF已生成"
    swPrgBar.UpdateProgress 80

    '保存后关闭文件
    swModel.Save
    swApp.CloseDoc swModel.GetTitle
    If isAsm Then
        Set swModel = swApp.ActiveDoc
        swApp.CloseDoc swModel.GetTitle
        swPrgBar.UpdateProgress 90
    End If
    swPrgBar.UpdateTitle "导图完成"
    swPrgBar.End

End Sub

'检查文件是否存在
Function IsFileExists(ByVal strFileName As String) As Boolean
    If Dir(strFileName, 16) <> Empty Then
        IsFileExists = True
    Else
        IsFileExists = False
    End If
End Function
许可协议

本文采用 CC BY-NC-SA 4.0 许可协议，转载请注明出处，谢谢！

分享文章
网站地图 | 状态监测 | 图片加密&解密 | File Server | 博友圈 | 博客说
Copyright 2022-2025 | Powered by Hexo 7.3.0 & Stellar 1.29.1
总访问量次 |