AnsweredAssumed Answered

Flat DXF macro don't work with 64 bit

Question asked by Peter Muesch on Jan 17, 2012
Latest reply on Mar 1, 2012 by Anthony Jones

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

Attachments

Outcomes