Macro to export selected sketch in SOLIDWORKS file to DXF/DWG file

Edit ArticleEdit Article
More 'Goodies'

DXF/DWG file created from the sketch
DXF/DWG file created from the sketch

This VBA macro exports the selected 2D sketch in part or assembly to DXF or DWG file.


Configure the name of the output file by modifying the EXPORT_NAME_TEMPLATE constant as shown below using free text and placeholders.

  • [title] placeholder will be replaced with the title of the original part or assembly file (without extension)
  • [sketch] placeholder will be replaced with the name of the sketch DXF\DWG file created from

Specify the extension (.dxf or .dwg) in the file template

File wil be saved in the same directory as original part or assembly document.

Const EXPORT_NAME_TEMPLATE As String = "ExportFile_[title]_[sketch].dxf"

Dim swApp As SldWorks.SldWorks

Const EXPORT_NAME_TEMPLATE As String = "[title]_[sketch].dxf"

Sub main()

    Set swApp = Application.SldWorks
    On Error GoTo catch
    Dim swModel As SldWorks.ModelDoc2
    Set swModel = swApp.ActiveDoc
    Dim swSelMgr As SldWorks.SelectionMgr
    Set swSelMgr = swModel.SelectionManager
    Dim swSketchFeat As SldWorks.Feature
    Set swSketchFeat = swSelMgr.GetSelectedObject6(1, -1)
    If swSketchFeat.GetTypeName2() = "ProfileFeature" Then
        swSketchFeat.Select2 False, -1
        Dim drawTemplate As String
        drawTemplate = swApp.GetUserPreferenceStringValue(swUserPreferenceStringValue_e.swDefaultTemplateDrawing)
        If drawTemplate = "" Then
            Err.Raise vbError, "", "Failed to find the default template"
        End If
        Dim swDraw As SldWorks.ModelDoc2
        Set swDraw = swApp.NewDocument(drawTemplate, swDwgPaperSizes_e.swDwgPapersUserDefined, 0.1, 0.1)
        Dim errs As Long
        Dim warns As Long
        Dim exportFilePath As String
        exportFilePath = GetExportFilePath(swModel, swSketchFeat)
        If False = swDraw.Extension.SaveAs(exportFilePath, swSaveAsVersion_e.swSaveAsCurrentVersion, swSaveAsOptions_e.swSaveAsOptions_Silent, Nothing, errs, warns) Then
            Err.Raise vbError, "", "Failed to export to DXF, DWG"
        End If
        swApp.CloseDoc swDraw.GetTitle
        Err.Raise vbError, "", "Please select 2D sketch to export"
    End If
    GoTo finally
    swApp.SendMsgToUser2 Err.Description, swMessageBoxIcon_e.swMbStop, swMessageBoxBtn_e.swMbOk
End Sub

Function GetExportFilePath(model As SldWorks.ModelDoc2, sketch As SldWorks.Feature) As String

    Const PLACEHOLDER_TITLE As String = "[title]"
    Const PLACEHOLDER_SKETCH As String = "[sketch]"
    Dim path As String
    Dim dir As String
    Dim title As String
    path = model.GetPathName
    If path = "" Then
        Err.Raise vbError, "", "Original model is never saved"
    End If
    title = Mid(path, InStrRev(path, "\") + 1, InStrRev(path, ".") - InStrRev(path, "\") - 1)
    dir = Left(path, InStrRev(path, "\"))
    Dim newTitle As String
    Dim newPath As String
    newTitle = Replace(newTitle, PLACEHOLDER_SKETCH, sketch.Name)
    newPath = dir & newTitle
    GetExportFilePath = newPath
End Function

Product of Xarial Product of Xarial