I have searched the forums and was unsuccessful at finding a macro that will export a flat dxf from the drawing. Everyone I try and the one I had freezes SW now that I switched to 64 bit machine. I will attach the macro I was using. I have tried opening the macro and clicking the references off and then back on and that didn't seem to work. I am not really familiar with macros either. Any help is appreciated.
Thanks
Sub main()
Dim swApp As SldWorks.SldWorks
Dim Part As ModelDoc2
Dim selMgr As SelectionMgr
Dim selData As SelectData
Dim myPath As String
Dim dxfFile As String
Dim confName As String
Dim myView As View
Dim myView2 As View
Dim mySheet As Sheet
Dim myDim As DisplayDimension
Dim myNote As note
Dim myWeld As WeldSymbol
Dim myMark As CenterMark
Dim myCLine As CenterLine
Dim myAnn As Object
Dim myAnn2 As Annotation
Dim errors As Long
Dim warnings As Long
Dim mx As Double
Dim my As Double
Dim i As Long
Dim j As Long
Dim k As Long
Dim n As Long
Dim sa As Variant
Dim sa1 As Variant
Dim fso As New Scripting.FileSystemObject
Dim ret As Boolean
Dim sketchesVisible As Boolean
Dim mySketch As Sketch
Dim mySeg As SketchSegment
Dim myPoint As SketchPoint
Dim p(2) As Double
Dim myEntity As entity
Dim boolStatus As Boolean
Dim myDCircle As DetailCircle
Dim myTable As TableAnnotation
Dim myOrigin As DatumOrigin
Dim myHoleTable As HoleTable
Dim myBendNotes() As String
Dim nBendNotes As Long
Dim myName As String
Dim isDone As Boolean
Dim myHatch As SketchHatch
Set swApp = Application.SldWorks
Set Part = swApp.ActiveDoc
If Part Is Nothing Then
MsgBox "The active document must be a drawing."
Exit Sub
End If
If Part.GetType <> 3 Then
MsgBox "The active document must be a drawing."
Exit Sub
End If
myPath = Part.GetPathName
If myPath = "" Then
MsgBox "The drawing must already have been saved."
Exit Sub
End If
' ********************************************************************************************************
If fso.FolderExists("C:\\DXF") Then
myPath = "C:\\DXF\\" & Part.GetTitle
End If
' ********************************************************************************************************
Set myView2 = Part.GetFirstView
Set myView2 = myView2.GetNextView
While (Not myView2 Is Nothing) And myView Is Nothing
If InStr(myView2.ReferencedConfiguration, "FLAT") > 0 Then
Set myView = myView2
End If
Set myView2 = myView2.GetNextView
Wend
Set selMgr = Part.SelectionManager
Set selData = selMgr.CreateSelectData
If myView Is Nothing Then
If selMgr.GetSelectedObjectCount <> 1 Then
MsgBox "You must select a drawing view first because a flat pattern wasnt found...."
Exit Sub
End If
If selMgr.GetSelectedObjectType2(1) <> swSelDRAWINGVIEWS Then
MsgBox "You must select a drawing view first because a flat pattern wasnt found...."
Exit Sub
End If
Set myView = selMgr.GetSelectedObject5(1)
End If
Part.SelectByID myView.Name, "DRAWINGVIEW", 0, 0, 0
Part.EditCopy
Part.ClearSelection
ret = Part.ActivateSheet("DXF-PROFILE")
If ret = True Then
Part.SelectByID "DXF-PROFILE", "SHEET", 0, 0, 0
Part.DeleteSelection False
End If
Part.NewSheet3 "DXF-PROFILE", 12, 13, 1, 1, 1, "*.drt", 2.5, 1.5, "Default"
Part.ActivateSheet "DXF-PROFILE"
Part.SelectByID "DXF-PROFILE", "SHEET", 0, 0, 0
Part.Paste
Set myView = Part.GetFirstView
Set myView = myView.GetNextView
Part.ActivateView myView.Name
Part.SetConsiderLeadersAsLines False
'Delete annotations
Part.ClearSelection2 True
Set myAnn = myView.GetFirstAnnotation3
While Not myAnn Is Nothing
Set myAnn2 = myAnn
Set myAnn = myAnn2.GetNext3
myAnn2.Select3 True, selData
Wend
Part.DeleteSelection False
'Delete dimensions
Set myDim = myView.GetFirstDisplayDimension3
While Not myDim Is Nothing
Set myAnn = myDim.GetAnnotation
myAnn.Select False
Part.DeleteSelection False
Set myDim = myView.GetFirstDisplayDimension3
Wend
'Delete notes
nBendNotes = -1
Set myNote = myView.GetFirstNote
While Not myNote Is Nothing
Set myAnn = myNote.GetAnnotation
myAnn.Select False
If myNote.IsBendLineNote Then
nBendNotes = nBendNotes + 1
ReDim Preserve myBendNotes(nBendNotes)
myBendNotes(nBendNotes) = myNote.GetName
Set myNote = myNote.GetNext
Part.HideDimension
Else
Set myNote = myNote.GetNext
Part.DeleteSelection False
End If
Wend
'Delete weld symbols
Set myWeld = myView.GetFirstWeldSymbol
While Not myWeld Is Nothing
Set myAnn = myWeld.GetAnnotation
myAnn.Select False
Set myWeld = myWeld.GetNext
Part.DeleteSelection False
Wend
'Delete old style centre marks
Set myMark = myView.GetFirstCenterMark
While Not myMark Is Nothing
Set myAnn = myMark.GetAnnotation
myAnn.Select False
Set myMark = myMark.GetNext
Part.DeleteSelection False
Wend
'Delete centre marks
sa = myView.GetCenterMarkInfo
If Not IsEmpty(sa) Then
j = 1
k = UBound(sa)
While j + 3 <= k
n = sa(j)
boolStatus = Part.Extension.SelectByID("", "CENTERMARKS", sa(j + 2), sa(j + 3), 0, False, 0, Nothing)
If boolStatus Then Part.DeleteSelection False
boolStatus = Part.Extension.SelectByID("", "CENTERMARKSYMS", sa(j + 2), sa(j + 3), 0, False, 0, Nothing)
If boolStatus Then Part.DeleteSelection False
j = j + 7 * n + 1
Wend
End If
'Delete centre lines
Set myCLine = myView.GetFirstCenterLine
While Not myCLine Is Nothing
Set myAnn = myCLine.GetAnnotation
myAnn.Select False
Set myCLine = myCLine.GetNext
Part.DeleteSelection False
Wend
'Delete detail circles
Part.ClearSelection2 True
sa = myView.GetDetailCircles
If Not IsEmpty(sa) Then
For k = 0 To UBound(sa)
Set myDCircle = sa(k)
Part.Extension.SelectByID myDCircle.GetName, "DETAILCIRCLE", 0, 0, 0, True, 0, Nothing
Next
Part.DeleteSelection False
End If
'Delete section lines
For i = 1 To 100
boolStatus = Part.Extension.SelectByID2("Section Line" & i, "SECTIONLINE", 0, 0, 0, False, 0, Nothing, 0)
If Not boolStatus = False Then Part.EditDelete
Next
'Delete sketch lines
Part.ClearSelection2 True
Part.ActivateView myView.Name
Set mySketch = myView.GetSketch
sa = mySketch.GetSketchSegments
If Not IsEmpty(sa) Then
For k = 0 To UBound(sa)
Set mySeg = sa(k)
If mySeg.Layer <> "LASERPROFILE" Then mySeg.Select4 True, selData
'mySeg.Select4 True, selData
Next
Part.DeleteSelection False
End If
'Delete sketch points
Part.ClearSelection2 True
sa = mySketch.GetSketchPoints
If Not IsEmpty(sa) Then
For k = 0 To UBound(sa)
Set myPoint = sa(k)
myPoint.Select4 True, selData
Next
Part.DeleteSelection False
End If
'Delete hatching
Part.ClearSelection2 True
sa = mySketch.GetSketchHatches
If Not IsEmpty(sa) Then
For k = 0 To UBound(sa)
Set myHatch = sa(k)
myHatch.Select4 True, selData
Next
Part.DeleteSelection False
End If
'Delete Hole Tables
Set myOrigin = myView.GetFirstDatumOrigin
While Not myOrigin Is Nothing
Set myHoleTable = myOrigin.Table
sa = myHoleTable.GetTableAnnotations
Set myOrigin = myOrigin.GetNext
If Not IsEmpty(sa) Then
For i = 0 To UBound(sa)
Set myTable = sa(i)
Set myAnn = myTable.GetAnnotation
myAnn.Select False
Part.DeleteSelection False
Next
End If
Wend
'Delete Annotation Tables
Set myTable = myView.GetFirstTableAnnotation
While Not myTable Is Nothing
Set myAnn = myTable.GetAnnotation
myAnn.Select False
Set myTable = myTable.GetNext
Part.DeleteSelection False
Wend
'Delete
'Delete spurious sketch points
Part.ClearSelection
For i = 1 To 100
boolStatus = Part.Extension.SelectByID("Point" & i, "SKETCHPOINT", 0, 0, 0, True, 0, Nothing)
Next
Part.DeleteSelection False
Part.SetDisplayWhenAdded True
Part.ClearSelection2 True
sa = myView.GetAnnotations
If Not IsEmpty(sa) Then
For i = 0 To UBound(sa)
Set myAnn2 = sa(i)
If myAnn2.GetType <> swNote Then
myAnn2.Select3 True, selData
Else
Set myNote = myAnn2.GetSpecificAnnotation
If myNote.IsBendLineNote Then
nBendNotes = nBendNotes + 1
ReDim Preserve myBendNotes(nBendNotes)
myBendNotes(nBendNotes) = myNote.GetName
Else
myAnn2.Select3 True, selData
End If
End If
Next
Part.DeleteSelection False
End If
Part.ClearSelection
For i = 1 To 1000
isDone = False
For j = 0 To nBendNotes
If myBendNotes(j) = "DetailItem" & i Then isDone = True
Next
If Not isDone Then
boolStatus = Part.Extension.SelectByID2("DetailItem" & i & "@" & myView.Name, "LEADER", 0, 0, 0, True, 0, Nothing, 0)
End If
Next
Part.DeleteSelection False
'Delete spurious Blocks
Dim SwSketchMgr
Dim vBlockDef
Dim swBlockDef
Dim vBlockInst
Dim swBlockInst
Dim sBlockName
Set SwSketchMgr = Part.SketchManager
vBlockDef = SwSketchMgr.GetSketchBlockDefinitions
If Not IsEmpty(vBlockDef) Then
For i = 0 To UBound(vBlockDef)
Set swBlockDef = vBlockDef(i)
vBlockInst = swBlockDef.GetInstances
If Not IsEmpty(vBlockInst) Then
For j = 0 To UBound(vBlockInst)
Set swBlockInst = vBlockInst(j)
sBlockName = swBlockInst.Name
boolStatus = Part.Extension.SelectByID2(sBlockName, "SUBSKETCHINST", 0, 0, 0, False, 0, Nothing, 0)
Part.EditDelete
Next j
End If
Next i
End If
'Switch off tangent lines and scale 1:1
myView.SetDisplayTangentEdges2 0
myView.ScaleDecimal = 1
Part.EditRebuild
'Reposition view to 0,0
mx = 0
my = 0
k = 0
sa1 = myView.GetPolylines4
Do While k < UBound(sa1)
k = k + 1
k = k + sa1(k) + 1
k = k + 6
If k > UBound(sa1) - 2 Then Exit Do
For j = 1 To sa1(k)
If sa1(k + 1) < mx Then mx = sa1(k + 1)
If sa1(k + 2) < my Then my = sa1(k + 2)
k = k + 3
Next
k = k + 1
Loop
p(0) = -mx
p(1) = -my
p(2) = 0
sa = p
myView.position = (sa)
Part.EditRebuild
'Switch off sketches
sketchesVisible = Part.GetUserPreferenceToggle(196)
ret = Part.SetUserPreferenceToggle(196, False)
Part.ClearSelection
boolStatus = Part.Extension.SelectByID(myView.Name, "DRAWINGVIEW", 0.0728108638326, -0.01699395229587, 0, False, 0, Nothing)
Part.ViewZoomToSelection
frmDlg.cdlg.CancelError = True
frmDlg.cdlg.Filter = "DXF Files (*.DXF)|*.dxf"
dxfFile = Replace(myPath, ".SLDDRW", "")
dxfFile = Replace(dxfFile, ".slddrw", "")
dxfFile = dxfFile & ".DXF"
frmDlg.cdlg.fileName = dxfFile
On Error GoTo exitSub
frmDlg.cdlg.ShowSave
dxfFile = frmDlg.cdlg.fileName
If fso.FileExists(dxfFile) Then fso.DeleteFile dxfFile
swApp.SetUserPreferenceIntegerValue swDxfOutputNoScale, 0
swApp.SetUserPreferenceIntegerValue swDxfVersion, swDxfFormat_R13
Part.SaveAs4 dxfFile, 0, 1, errors, warnings
ret = Part.SetUserPreferenceToggle(196, sketchesVisible)
Part.SheetPrevious
boolStatus = Part.Extension.SelectByID("DXF-PROFILE", "SHEET", 0, 0, 0, False, 0, Nothing)
Part.DeleteSelection False
exitSub:
End Sub
