This website uses cookies to ensure you get the best experience on our website. By using our website you agree on the following Cookie Policy, Privacy Policy, and Terms Of Use
When exporting part file to most of the foreign format supported by SOLIDWORKS it is possible to select the scope bodies of export, allowing to only process selected bodies.
However this feature is not supported by all formats. For example the formats such as 3D xml, xaml, amf, 3mf will always export all bodies, regardless of the selection.
This VBA macro allows to export only selected bodies to any format supported by SOLIDWORKS.
Select the bodies, faces, edges or vertices and run the macro and specify the name of export to produce a result.
PrivateDeclare PtrSafe Function GetSaveFileName Lib"comdlg32.dll"Alias"GetSaveFileNameA" (pOpenfilename As OPENFILENAME) As LongPtr
Private Type OPENFILENAME
lStructSize AsLong
hwndOwner As LongPtr
hInstance As LongPtr
lpstrFilter AsString
lpstrCustomFilter AsString
nMaxCustFilter AsLong
nFilterIndex AsLong
lpstrFile AsString
nMaxFile AsLong
lpstrFileTitle AsString
nMaxFileTitle AsLong
lpstrInitialDir AsString
lpstrTitle AsString
Flags As LongPtr
nFileOffset AsInteger
nFileExtension AsInteger
lpstrDefExt AsString
lCustData AsLong
lpfnHook AsLong
lpTemplateName AsStringEnd Type
Const FILTER AsString = "3D Manufacturing Format (*.3mf)|*.3mf|3D XML (*.3dxml)|*.3dxml|Additive Manufacturing File (*.amf)|*.amf|Microsoft XAML (*.xaml)|*.xaml|All Files (*.*)|*.*"Dim swApp As SldWorks.SldWorks
Sub main()
Set swApp = Application.SldWorks
try_:
OnErrorGoTo catch_
Dim swModel As SldWorks.ModelDoc2
Set swModel = swApp.ActiveDoc
If swModel IsNothingThen
Err.Raise vbError, "", "Please open model"EndIfDim vBodies AsVariant
vBodies = CollectSelectedBodies(swModel)
IfNot IsEmpty(vBodies) ThenDim filePath AsString
filePath = BrowseForFileSave("Select file path to save", FILTER)
If filePath <> ""Then
ExportBodies filePath, vBodies
EndIfElse
Err.Raise vbError, "", "Select bodies to export"EndIfGoTo finally_
catch_:
swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
finally_:
EndSubFunction BrowseForFileSave(title AsString, filters AsString) AsStringDim of As OPENFILENAME
Const FILE_PATH_BUFFER_SIZE AsInteger = 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) ThenDim filePath AsString
filePath = Left(of.lpstrFile, InStr(of.lpstrFile, vbNullChar) - 1)
Dim vFilters AsVariant
vFilters = Split(FILTER, "|")
Dim ext AsString
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
EndIf
BrowseForFileSave = filePath
Else
BrowseForFileSave = ""EndIfEndFunctionFunction CollectSelectedBodies(model As SldWorks.ModelDoc2) AsVariantDim swSelMgr As SldWorks.SelectionMgr
Dim swBodies() As SldWorks.Body2
Set swSelMgr = model.SelectionManager
Dim i AsIntegerFor i = 1 To swSelMgr.GetSelectedObjectCount2(-1)
Dim swSelObj AsObjectSet swSelObj = swSelMgr.GetSelectedObject6(i, -1)
Dim swBody As SldWorks.Body2
IfTypeOf swSelObj Is SldWorks.Body2 ThenSet swBody = swSelObj
ElseIfTypeOf swSelObj Is SldWorks.Feature ThenDim swFeat As SldWorks.Feature
Set swFeat = swSelObj
Dim swFeatFace As SldWorks.Face2
Set swFeatFace = swFeat.GetFaces()(0)
Set swBody = swFeatFace.GetBody
ElseIfTypeOf swSelObj Is SldWorks.Face2 ThenDim swFace As SldWorks.Face2
Set swFace = swSelObj
Set swBody = swFace.GetBody
ElseIfTypeOf swSelObj Is SldWorks.Edge ThenDim swEdge As SldWorks.Edge
Set swEdge = swSelObj
Set swBody = swEdge.GetBody
ElseIfTypeOf swSelObj Is SldWorks.Vertex ThenDim 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, "", "Cannot find body of the selected object " & i
EndIfIfNot Contains(swBodies, swBody) ThenIf (Not swBodies) = -1 ThenReDim swBodies(0)
ElseReDimPreserve swBodies(UBound(swBodies) + 1)
EndIfSet swBodies(UBound(swBodies)) = swBody
EndIfNext
CollectSelectedBodies = swBodies
EndFunctionSub ExportBodies(filePath AsString, vBodies AsVariant)
Dim swTempPart As SldWorks.ModelDoc2
Dim swPartTemplate AsString
swPartTemplate = swApp.GetUserPreferenceStringValue(swUserPreferenceStringValue_e.swDefaultTemplatePart)
If swPartTemplate = ""Then
Err.Raise vbError, "", "No default part template found"EndIfDim curErr As ErrObject
try_:
OnErrorGoTo catch_
Set swTempPart = swApp.NewDocument(swPartTemplate, swDwgPaperSizes_e.swDwgPapersUserDefined, 0, 0)
Dim i AsIntegerFor 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 IsNothingThen
Err.Raise vbError, "", "Failed to create feature from body"EndIfNextDim errs AsLongDim warns AsLongIfFalse = swTempPart.Extension.SaveAs(filePath, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errs, warns) Then
Err.Raise vbError, "", "Failed to export file. Error code:" & errs
EndIfGoTo finally_
catch_:
Set curErr = Err
finally_:
IfNot swTempPart IsNothingThen
swApp.CloseDoc swTempPart.GetTitle
EndIfIfNot curErr IsNothingThen
Err.Raise curErr.Number, curErr.Source, curErr.Description
EndIfEndSubFunction Contains(vArr AsVariant, item AsObject) AsBooleanDim i AsIntegerIfNot IsEmpty(vArr) ThenFor i = 0 To UBound(vArr)
If vArr(i) Is item Then
Contains = TrueExitFunctionEndIfNextEndIf
Contains = FalseEndFunction