' **********************************************************************
' * Makro erzeugt aus dem aktiven Zeichnungsdokument für alle Blätter
' * eine PDF Datei im Unterverzeichnis PDF der Zeichnung. Es werden alle
' * Blätter unter dem Namen kombiniert mit dem Blattnamen abgespeichert.
' *
' * Basiert auf einer Vorlage von:
' *
' * 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 strPDFDateiname     As String
Dim strDateinameLang    As String
Dim strPfad             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 PDF anschließend im Unterverzeichnis PDF der Zeichnung gespeichert
    ' werden, muss der Pfad ermittelt werden.
    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
    
    ' PDF-Dateien sollen im Unterverzeichnis PDF abgespeichert werden;
    strPDFPfad = strPfad + "PDF\"
    
    ' Prüfung, ob die Verzeichnisse überhaupt existiert, da sie sonst angelegt
    ' werden müssen
    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 PDF mit den eingestellten Optionen abspeichern
        Set swSheet = swDrawingDoc.GetCurrentSheet
        strSheetName = swSheet.GetName
        strPDFDateiname = strPDFPfad & strDateiname & ".pdf"
        
        ' dann erfolgt das Speichern als PDF mittels swModelDocExt.SaveAs
        ' wenn alles geklappt hat, wird TRUE zurückgeliefert, ansonsten FALSE
        
        Set swModelDocExt = swDrawingDoc.Extension
        Set swExportPDFData = swApp.GetExportFileData(1)
        
        bReturn = swExportPDFData.SetSheets(swExportData_ExportCurrentSheet, Nothing)
        

        bReturn = swModelDocExt.SaveAs(strPDFDateiname, swSaveAsCurrentVersion, swSaveAsOptions_Copy, _
                     swExportPDFData, lErrors, lWarnings)
        
        If bReturn Then
            strMsgtxt = strMsgtxt & "erfolgreich gespeichert: " & strDateiname & _
                     ".pdf" & Chr$(10) & Chr$(13)
        Else
            intReturn = swApp.SendMsgToUser2("FEHLER BEIM SPEICHERN VON " & strDateiname & _
                   ".pdf" & Chr$(10) & Chr$(13), swMbInformation, swMbOk)
            strMsgtxt = strMsgtxt & "*** FEHLER bei: " & strDateiname & _
                     ".pdf" & 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 noch die Zusammenfassung übers Speichern ausgeben
    intReturn = swApp.SendMsgToUser2(strMsgtxt, swMbInformation, swMbOk)
    
End Sub