' **********************************************************************
' * Makro erzeugt aus dem aktiven Zeichnungsdokument für alle Blätter
' * eine DXF Datei im Verzeichnis der Zeichnung. Es werden alle Blätter
' * unter dem Namen kombiniert mit dem Blattnamen abgespeichert.
' *
' * 05.04.2001 Stefan Berlitz (stefan.berlitz@solidworks.cad.de)
' * http://solidworks.cad.de
' * http://swtools.cad.de
' **********************************************************************
Option Explicit

Dim swApp               As SldWorks.SldWorks
Dim swDrawingDoc        As SldWorks.ModelDoc2
Dim swSheet             As SldWorks.Sheet
Dim swModelDocExt       As SldWorks.ModelDocExtension
Dim swExportPDFData     As SldWorks.ExportPdfData
Dim swPs                As SldWorks.PageSetup

Dim bReturn             As Boolean
Dim bCollate            As Boolean

Dim vSheets             As Variant
Dim vSheetProps         As Variant
Dim vPageArray          As Variant

Dim strDateiname        As String
Dim strDXFDateiname     As String
Dim strPDFDateiname     As String
Dim strDateinameLang    As String
Dim strPfad             As String
Dim strDXFPfad          As String
Dim strPDFPfad          As String
Dim strMsgtxt           As String
Dim strSheetName        As String
Dim strPrinter           As String

Dim i                   As Long
Dim lAnzahlBl           As Long
Dim lErrors             As Long
Dim lWarnings           As Long
Dim lFarbe              As Long
Dim lPageArray          As Long
Dim lCopies             As Long


Dim intReturn           As Integer



Sub main()
    
    'Anbindung an SWX
    Set swApp = Application.SldWorks
    Set swDrawingDoc = swApp.ActiveDoc
    strMsgtxt = ""
    
    ' wenn keine Zeichnung aktiv wird das Makro wieder beendet
    If (swDrawingDoc.GetType <> swDocDRAWING) Then
        MsgBox "Nur für Zeichnungen geeignet"
        Exit Sub
    End If
    
    ' Prüfung, ob Zeichnung gespeichert werden muss. Falls Zeichnung nicht
    ' gespeichert wird, Abbruch!
    If swDrawingDoc.GetSaveFlag Then
        intReturn = swApp.SendMsgToUser2("Soll die Zeichnung gesichert werden?", swMbQuestion, swMbYesNo)
        If intReturn = swMbHitYes Then
            bReturn = swDrawingDoc.Save3(swSaveAsOptions_Silent, lErrors, lWarnings)
        Else
            intReturn = swApp.SendMsgToUser2("Bitte die Zeichnung speichern!", swMbInformation, swMbOk)
            Exit Sub
        End If
    End If
    
    ' die Anzahl der Blätter holen, und dann in der Schleife eines nach
    ' dem anderen Abspeichern. Dazu ein Handle auf das aktuelle Blatt holen
    lAnzahlBl = swDrawingDoc.GetSheetCount
    Set swSheet = swDrawingDoc.GetCurrentSheet
    
    ' damit die DXF anschließend im Unterverzeichnis DXF der Zeichnung gespeichert
    ' werden, muss der Pfad ermittelt werden. Ansonsten werden die DXFs im Verzeich-
    ' nis des Makro gespeichert. Das PDF kommt in das Unterverzeichnis PDF.
    strDateinameLang = swDrawingDoc.GetPathName
    
    ' Zerlegen in Pfad und Dateiname ohne Extension (7 Zeichen)
    For i = Len(strDateinameLang) To 1 Step -1
        If Mid(strDateinameLang, i, 1) = "\" Then
            strPfad = Left(strDateinameLang, i)
            strDateiname = Mid(strDateinameLang, i + 1, Len(strDateinameLang) - i - 7)
            Exit For
        End If
    Next i
    
    ' DXF-Dateien sollen im Unterverzeichnis DXF abgespeichert werden;
    ' PDF-Datei entsprechend ins Unterverzeichnis PDF.
    strDXFPfad = strPfad + "DXF\"
    strPDFPfad = strPfad + "PDF\"
    
    ' Prüfung, ob die Verzeichnisse überhaupt existiert, da sie sonst angelegt
    ' werden müssen
    If Len(Dir(strDXFPfad, vbDirectory)) = 0 Then
        MkDir (strDXFPfad)
    End If
    If Len(Dir(strPDFPfad, vbDirectory)) = 0 Then
        MkDir (strPDFPfad)
    End If
    
    ' wenn mehr als ein Blatt da ist könnte es sein, dass wir nicht auf
    ' Blatt 1 sind. In einem Makro müssen wir jetzt einen Trick machen, um
    ' auf das erste Blatt zurückzukommen.
    ' Dazu immer wieder ein Blatt zurückspringen und dabei den Blattnamen
    ' vergleichen; wenn der gleich bleibt haben wir das erste Blatt erreicht.
    strSheetName = swSheet.GetName
    For i = 1 To lAnzahlBl - 1
        swDrawingDoc.SheetPrevious
        Set swSheet = swDrawingDoc.GetCurrentSheet
        If (strSheetName = swSheet.GetName) Then
            Exit For
        End If
    Next i
        
    ' jetzt sind wir garantiert auf dem ersten Blatt und können jetzt eins
    ' nach dem anderen Abspeichern
    For i = 1 To lAnzahlBl
        
        ' wir wollen alle Blätter als DXF mit den eingestellten Optionen abspeichern
        Set swSheet = swDrawingDoc.GetCurrentSheet
        strDXFDateiname = strDXFPfad & strDateiname & " - " & swSheet.GetName & ".dxf"
        
        ' dann erfolgt das Speichern als DXF mittels swModelDocExt.SaveAs
        ' wenn alles geklappt hat, wird TRUE zurückgeliefert, ansonsten FALSE
        
        Set swModelDocExt = swDrawingDoc.Extension
        Set swExportPDFData = Nothing

        bReturn = swModelDocExt.SaveAs(strDXFDateiname, swSaveAsCurrentVersion, swSaveAsOptions_Copy, _
                     swExportPDFData, lErrors, lWarnings)
        
        If bReturn Then
            strMsgtxt = strMsgtxt & "erfolgreich gespeichert: " & strDateiname & " - " & swSheet.GetName & _
                     ".dxf" & Chr$(10) & Chr$(13)
        Else
            intReturn = swApp.SendMsgToUser2("FEHLER BEIM SPEICHERN VON " & strDateiname & " - " & swSheet.GetName & _
                   ".dxf" & Chr$(10) & Chr$(13), swMbInformation, swMbOk)
            strMsgtxt = strMsgtxt & "*** FEHLER bei: " & strDateiname & " - " & swSheet.GetName & _
                     ".dxf" & Chr$(10) & Chr$(13)
        End If
        
        
        ' und wenn noch Blätter kommen dieses aktivieren
        If lAnzahlBl > i Then
            swDrawingDoc.SheetNext
        End If
    Next i
    
    'und jetzt das Ganze für das PDF mit Druck über Adobe Acrobat
    ' Anbinden an den Druckeinstellungsdialog und Werte einstellen
    Set swPs = swDrawingDoc.PageSetup
    
    lPageArray = 0
    vPageArray = lPageArray ' bei 0 werden alle Seiten ausgegeben
    lCopies = 1             ' Anzahl der Ausdrucke
    bCollate = True        ' Sortiertes Drucken
    swPs.DrawingColor = 1   'Farben in Zeichnungen, Automatisch = 1 Farb-/Grauskalierung = 2 Schwarz und Weiß = 3
    swPs.ScaleToFit = False 'Maßstab an Papier anpassen, False/True
    swPs.Scale2 = 100       'Skalierungswert in Prozent
    swPs.HighQuality = True 'Hohe Qualität, False/True
    swPs.Orientation = 2    'Ausrichtung Hochformat = 1 Querformat = 2
    strPrinter = "Adobe PDF" 'Drucker eintragen, Name aus Auswahlbox im Druckmenu (exakt)

    ' Eigenschaften des Blattes holen, um Format zu bestimmen
    vSheetProps = swSheet.GetProperties

    Select Case vSheetProps(0)

        Case 6  'A4 Querformat
            swPs.PrinterPaperSize = 9
            swPs.PrinterPaperSource = 9
    
        Case 7  'A4 Hochformat
            swPs.Orientation = 1
            swPs.PrinterPaperSize = 9
            swPs.PrinterPaperSource = 9
    
        Case 8  'A3 Querformat
            swPs.PrinterPaperSize = 8
            swPs.PrinterPaperSource = 8
    
        Case 9  'A2 Querformat
            swPs.PrinterPaperSize = 66
            swPs.PrinterPaperSource = 66

        Case 10  'A1 Querformat
            swPs.PrinterPaperSize = 133
            swPs.PrinterPaperSource = 133

        Case 11  'A0 Querformat
            swPs.PrinterPaperSize = 134
            swPs.PrinterPaperSource = 134

        Case Else
            strMsgtxt = "Benutzerdefinierte Größe. Bitte manuell drucken."
            intReturn = swApp.SendMsgToUser2(strMsgtxt, swMbInformation, swMbOk)
            Exit Sub
    
    End Select

    swModelDocExt.PrintOut3 vPageArray, lCopies, bCollate, strPrinter, "", swPs.HighQuality

        
    ' und noch die Zusammenfassung übers Speichern ausgeben
    intReturn = swApp.SendMsgToUser2(strMsgtxt, swMbInformation, swMbOk)
End Sub