Range als PDF speichern mit Auswahldialog...

Frage: Zwei Dinge. Einmal kann ein Range in ein PDF gespeichert werden. Mit Auswahldialog zum speichern (Das ist in "Private Sub CommandButton1_Click()" gelöst). Die PDF - Datei soll dann angezeigt werden.

Dann wird es aber schwieriger. Die PDF - Datei soll erst 5 Sekunden angezeigt werden, dann soll die Nachfrage kommen, ob gespeichert werden soll, oder nicht. Bei Nein wird die temporäre Datei (ist im Tempordner) vom PC gelöscht. Bei Ja kommt der Speicherdialog. Das ist in "Private Sub CommandButton2_Click()" gelöst.

Hier noch eine Beispieldatei: Range als PDF speichern mit Auswahldialog...

Code in das Klassenmodul der Tabelle in der die CommandButton sind:

Option Explicit
Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
    (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function SetForegroundWindow Lib "user32" _
    (ByVal hwnd As Long) As Long
'-------------------------------------------------------------------------- 
' Module    : Tabelle1 
' Procedure : CommandButton1_Click 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : Range als PDF speichern mit Auswahldialog... 
'-------------------------------------------------------------------------- 
Private Sub CommandButton1_Click()
    Dim varPath As Variant
    Dim RngRange As Range
    On Error GoTo Fin
    Set RngRange = Union(Range("B6:G46"), Range("B49:G89"), _
        Range("B91:G132"), Range("B135:G175"))
    varPath = Application.GetSaveAsFilename( _
        InitialFileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name, _
        FileFilter:="PDF(*.pdf), *.pdf", _
        Title:="Speichern als PDF")
    If Not varPath = False Then
        RngRange.ExportAsFixedFormat 0, varPath, , , , , , True
    Else
        MsgBox "Abbrechen geklickt..."
    End If
Fin:
    Set RngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
'-------------------------------------------------------------------------- 
' Module    : Tabelle1 
' Procedure : CommandButton2_Click 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : PDF erst anzeigen, dann Nachfrage - Ja PDF speichern, 
'             bei Nein PDF schliessen und temporäre Datei löschen... 
'-------------------------------------------------------------------------- 
Private Sub CommandButton2_Click()
    Dim varPath As Variant
    Dim RngRange As Range
    On Error GoTo Fin
    Set RngRange = Union(Range("B6:G46"), Range("B49:G89"), _
        Range("B91:G132"), Range("B135:G175"))
    RngRange.ExportAsFixedFormat 0, Environ$("TMP") & "\TMPpdf", , , , , , True
    Application.Wait Now + TimeSerial(0, 0, 5)
    SetForegroundWindow (FindWindow("xlMain", vbNullString))
    Select Case MsgBox("PDF speichern?", 4 Or 32 Or 0, "PDF")
        Case vbYes
            varPath = Application.GetSaveAsFilename( _
                InitialFileName:=ThisWorkbook.Path & "\" & ActiveSheet.Name, _
                FileFilter:="PDF(*.pdf), *.pdf", _
                Title:="Speichern als PDF")
                If Not varPath = False Then
                    RngRange.ExportAsFixedFormat 0, varPath
                End If
                Call PDFClose("TMPpdf.pdf")
        Case vbNo
            Call PDFClose("TMPpdf.pdf")
            Application.Wait Now + TimeSerial(0, 0, 1)
            Kill (Environ$("TMP") & "\TMPpdf.pdf")
    End Select
Fin:
    Set RngRange = Nothing
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub

Code in ein allgemeines Modul:

Option Explicit
Private Declare Function FindWindow Lib "user32" _
    Alias "FindWindowA" (ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function PostMessage Lib "user32" _
    Alias "PostMessageA" (ByVal hwnd As Long, _
    ByVal wMsg As Long, ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Declare Function OpenProcess Lib "kernel32" _
    (ByVal dwDesiredAccess As Long, ByVal bInheritHandle As Long, _
    ByVal dwProcessId As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib "user32" _
    (ByVal hwnd As Long, lpdwProcessId As Long) As Long
Declare Function GetParent Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" _
    (ByVal hwnd As Long, ByVal lpString As String, ByVal cch As Long) As Long
Private Declare Function GetWindow Lib "user32" (ByVal hwnd As Long, _
    ByVal wCmd As Long) As Long
Const GW_HWNDNEXT = 2
Const WM_CLOSE = &H10
Const SYNCHRONIZE = &H100000
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : PDFClose 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 31.10.2012 
' Purpose   : PDF - Datei schliessen... 
' Quelle    : http://support.microsoft.com/kb/147659/en-us/ 
'-------------------------------------------------------------------------- 
Public Sub PDFClose(ByVal strTMP As String)
    Dim hWindow As Long
    Dim hProcess As Long
    Dim lProcessId As Long
    Dim lngReturnValue As Long
    hWindow = SearchHndByWndName_Parent(strTMP)
    hProcess = OpenProcess(SYNCHRONIZE, 0&, lProcessId)
    lngReturnValue = PostMessage(hWindow, WM_CLOSE, 0&, 0&)
End Sub
Private Function SearchHndByWndName_Parent(strSearch As String) As Long
    Dim strTMP As String * 100
    Dim nhWnd As Long
    nhWnd = FindWindow(vbNullString, vbNullString)
    Do While Not nhWnd = 0
        If GetParent(nhWnd) = 0 Then
            GetWindowText nhWnd, strTMP, 100
            If InStr(strTMP, strSearch) > 0 Then
                SearchHndByWndName_Parent = nhWnd
                Exit Do
            End If
        End If
        nhWnd = GetWindow(nhWnd, GW_HWNDNEXT)
    Loop
End Function

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...