AnsweredAssumed Answered

Cannot get this macro to work to save my dxf at a desired location

Question asked by Baljinder Shahi on Jan 10, 2019
Latest reply on Jan 10, 2019 by Cad Admin

Can somebody Please help rectify problem in this code i am very bad at VBA


Option Explicit

Private Const BIF_RETURNONLYFSDIRS As Long = &H1



Private Const BIF_BROWSEFORCOMPUTER As Long = &H1000

Private Const BIF_BROWSEFORPRINTER As Long = &H2000

Private Const BIF_BROWSEINCLUDEFILES As Long = &H4000

Private Const MAX_PATH As Long = 260



Dim swApp As SldWorks.SldWorks



Dim swModel As SldWorks.ModelDoc2

Dim swPart As SldWorks.PartDoc

Dim swSelMgr As SelectionMgr

Dim swSelData As SelectData

Dim swFace As Face2

Dim swSurf As Surface

Dim sModelName As String

Dim sPathName As String

Dim varAlignment As Variant

Dim dataAlignment(11) As Double

Dim varViews As Variant

Dim dataViews(1) As String

Dim options As Long

Dim exportType As String

Dim numSel As Integer

Dim selType As Integer

Dim result As Boolean

Dim i As Integer





Function BrowseFolder(Optional Caption As String, _

    Optional InitialFolder As String) As String



Dim SH As Shell32.Shell

Dim F As Shell32.Folder



Set SH = New Shell32.Shell

Set F = SH.BrowseForFolder(0&, Caption, BIF_RETURNONLYFSDIRS, InitialFolder)

If Not F Is Nothing Then

    BrowseFolder = F.Items.Item.Path

End If



End Function





Sub exportDXF()

'*** Change to dxf or dwg depending on which file type you want to export

exportType = "dxf" '"dwg"






'Get Solidworks and and active model

Set swApp = Application.SldWorks

Set swModel = swApp.ActiveDoc



'Make sure a model is open

If swModel Is Nothing Then

    MsgBox ("Error! No model open")

    Exit Sub

End If



'Make sure model is part

If swModel.GetType = swDocPART Then

    Set swPart = swModel


    MsgBox ("Error! Must use part document")

    Exit Sub

End If



'Set the selection manager and get the number of selections

Set swSelMgr = swModel.SelectionManager

numSel = swSelMgr.GetSelectedObjectCount2(-1)



'Make sure at least one face is selected

If numSel < 1 Then

    MsgBox ("Error! Please select at least one planar face to export")

    Exit Sub

End If



'Check all selections are planar faces

For i = 1 To numSel



    Set swFace = swSelMgr.GetSelectedObject6(i, -1)

    Set swSurf = swFace.GetSurface


    'Exit for nonplanar surface

    If swSurf.IsPlane = False Then

    MsgBox ("Error! Non planar surface selected")

    Exit Sub

    End If



Next i



'Get the pathname

sModelName = swModel.GetPathName

sPathName = BrowseFolder(Caption:="Select A Folder/Path")



    If sPathName = "" Then

    MsgBox "Please select the path and try again"



    sPathName = sPathName & "\"

    Exit Sub

    End If







'change the file extension to dxf (or dwg)

sPathName = Left(sPathName, Len(sPathName) - 6)

sPathName = sPathName + exportType



'Define the alignment types

'I had to set them all to 0 in order to output in same orientation as 3D model

dataAlignment(0) = 0#

dataAlignment(1) = 0#

dataAlignment(2) = 0#

dataAlignment(3) = 0#

dataAlignment(4) = 0#

dataAlignment(5) = 0#

dataAlignment(6) = 0#

dataAlignment(7) = 0#

dataAlignment(8) = 0#

dataAlignment(9) = 0#

dataAlignment(10) = 0#

dataAlignment(11) = 0#


varAlignment = dataAlignment


'Export the selected face(s) to a DXF/DWG

result = swPart.ExportToDWG2(sPathName, sModelName, swExportToDWG_ExportSelectedFacesOrLoops, True, varAlignment, False, False, options, Nothing)



'Show error message if failed to save

If result = False Then

    MsgBox ("Error! Failed to export. Check selections and try again.")

    Exit Sub

End If



End Sub