将选定的实体导出为外部格式的宏
在将零件文件导出为SOLIDWORKS支持的大多数外部格式时,可以选择导出的实体范围,从而只处理选定的实体。
然而,并非所有格式都支持此功能。例如,3D xml、xaml、amf、3mf等格式将始终导出所有实体,而不考虑选择。
此VBA宏允许将只选定的实体导出到SOLIDWORKS支持的任何格式。
选择实体、面、边或顶点,运行宏并指定导出的名称以生成结果。
Private Declare PtrSafe Function GetSaveFileName Lib "comdlg32.dll" Alias "GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As LongPtr
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
Flags As LongPtr
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Const FILTER As String = "3D制造格式 (*.3mf)|*.3mf|3D XML (*.3dxml)|*.3dxml|增材制造文件 (*.amf)|*.amf|Microsoft XAML (*.xaml)|*.xaml|所有文件 (*.*)|*.*"
Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
try_:
On Error GoTo catch_
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If swModel Is Nothing Then
Err.Raise vbError, "", "请打开模型"
End If
Dim vBodies As Variant
vBodies = CollectSelectedBodies(swModel)
If Not IsEmpty(vBodies) Then
Dim filePath As String
filePath = BrowseForFileSave("选择要保存的文件路径", FILTER)
If filePath <> "" Then
ExportBodies filePath, vBodies
End If
Else
Err.Raise vbError, "", "请选择要导出的实体"
End If
GoTo finally_
catch_:
swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally_:
End Sub
Function BrowseForFileSave(title As String, filters As String) As String
Dim of As OPENFILENAME
Const FILE_PATH_BUFFER_SIZE As Integer = 260
of.lpstrFilter = Replace(filters, "|", Chr(0)) & Chr(0)
of.lpstrTitle = title
of.nMaxFile = FILE_PATH_BUFFER_SIZE
of.nMaxFileTitle = FILE_PATH_BUFFER_SIZE
of.lpstrFile = String(FILE_PATH_BUFFER_SIZE, Chr(0))
of.Flags = &H200000
of.lStructSize = LenB(of)
If GetSaveFileName(of) Then
Dim filePath As String
filePath = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
Dim vFilters As Variant
vFilters = Split(FILTER, "|")
Dim ext As String
ext = vFilters((of.nFilterIndex - 1) * 2 + 1)
ext = Right(ext, Len(ext) - InStrRev(ext, ".") + 1)
If LCase(Right(filePath, Len(ext))) <> LCase(ext) Then
filePath = filePath & ext
End If
BrowseForFileSave = filePath
Else
BrowseForFileSave = ""
End If
End Function
Function CollectSelectedBodies(model As SldWorks.ModelDoc2) As Variant
Dim swSelMgr As SldWorks.SelectionMgr
Dim swBodies() As SldWorks.Body2
Set swSelMgr = model.SelectionManager
Dim i As Integer
For i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
Dim swSelObj As Object
Set swSelObj = swSelMgr.GetSelectedObject6(i, -1)
Dim swBody As SldWorks.Body2
If TypeOf swSelObj Is SldWorks.Body2 Then
Set swBody = swSelObj
ElseIf TypeOf swSelObj Is SldWorks.Feature Then
Dim swFeat As SldWorks.Feature
Set swFeat = swSelObj
Dim swFeatFace As SldWorks.Face2
Set swFeatFace = swFeat.GetFaces()(0)
Set swBody = swFeatFace.GetBody
ElseIf TypeOf swSelObj Is SldWorks.Face2 Then
Dim swFace As SldWorks.Face2
Set swFace = swSelObj
Set swBody = swFace.GetBody
ElseIf TypeOf swSelObj Is SldWorks.Edge Then
Dim swEdge As SldWorks.Edge
Set swEdge = swSelObj
Set swBody = swEdge.GetBody
ElseIf TypeOf swSelObj Is SldWorks.Vertex Then
Dim swVertex As SldWorks.Vertex
Set swVertex = swSelObj
Dim swVertEdge As SldWorks.Edge
Set swVertEdge = swVertex.GetEdges()(0)
Set swBody = swVertEdge.GetBody
Else
Err.Raise vbError, "", "无法找到所选对象的实体 " & i
End If
If Not Contains(swBodies, swBody) Then
If (Not swBodies) = -1 Then
ReDim swBodies(0)
Else
ReDim Preserve swBodies(UBound(swBodies) + 1)
End If
Set swBodies(UBound(swBodies)) = swBody
End If
Next
CollectSelectedBodies = swBodies
End Function
Sub ExportBodies(filePath As String, vBodies As Variant)
Dim swTempPart As SldWorks.ModelDoc2
Dim swPartTemplate As String
swPartTemplate = swApp.GetUserPreferenceStringValue(swUserPreferenceStringValue_e.swDefaultTemplatePart)
If swPartTemplate = "" Then
Err.Raise vbError, "", "未找到默认零件模板"
End If
Dim curErr As ErrObject
try_:
On Error GoTo catch_
Set swTempPart = swApp.NewDocument(swPartTemplate, swDwgPaperSizes_e.swDwgPapersUserDefined, 0, 0)
Dim i As Integer
For i = 0 To UBound(vBodies)
Dim swBody As SldWorks.Body2
Set swBody = vBodies(i)
Set swBody = swBody.Copy
Dim swBodyFeat As SldWorks.Feature
Set swFeat = swTempPart.CreateFeatureFromBody3(swBody, False, swCreateFeatureBodyOpts_e.swCreateFeatureBodySimplify)
If swFeat Is Nothing Then
Err.Raise vbError, "", "无法从实体创建特征"
End If
Next
Dim errs As Long
Dim warns As Long
If False = swTempPart.Extension.SaveAs(filePath, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errs, warns) Then
Err.Raise vbError, "", "导出文件失败。错误代码:" & errs
End If
GoTo finally_
catch_:
Set curErr = Err
finally_:
If Not swTempPart Is Nothing Then
swApp.CloseDoc swTempPart.GetTitle
End If
If Not curErr Is Nothing Then
Err.Raise curErr.Number, curErr.Source, curErr.Description
End If
End Sub
Function Contains(vArr As Variant, item As Object) As Boolean
Dim i As Integer
If Not IsEmpty(vArr) Then
For i = 0 To UBound(vArr)
If vArr(i) Is item Then
Contains = True
Exit Function
End If
Next
End If
Contains = False
End Function