Code Optimierung - Mein Projekt

[sandormiles]

Nabend!

Ich muss das mit dem PDF-Dokument erstellen nochmal aufgreifen. Habe ich ein PDF-Dokument erstellt und ist Adobe noch geöffnet und erstelle ich ein weiteres Dokument, dann gibt es eine Laufzeitfehler.

Code:

Dim pdfName As Variant, DtTxt As String, UserTxt As String

    DtTxt = Format(Date, "DD-MM-YYYY")
    UserTxt = Application.UserName
    
    

pdfName = Application.GetSaveAsFilename(Environ("USERPROFILE") & "\Desktop\" & "Liste alle offenen Widersprüche mit Rückforderung - Wohn A" & "_" & DtTxt & "_" & UserTxt & ".pdf", "PDF-Dateien (*.pdf), *.pdf")

If pdfName <> False Then
Sheets("Listen_Wohn A").ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfName, _
                          Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintareas:=False, _
                          OpenAfterPublish:=True
End If

Setze ich OpenAfterPublish auf False, dann kommt die Meldung nicht, aber dann ist ja auch Adobe nicht gestartet. Jemand ne Idee?

Grüße zum Mittwochabend
Sandor

[Steffl]

Hallo,

schau mal hier vorbei. Beachte aber bitte die Anweisungen von Isabelle!

[sandormiles]

Hallo Stefan,

danke für den Link, aber ich glaube ich bin nicht die hellste Kerze auf der Torte, wenn es um VBA geht

Habe nun den Code

Code:

Option Explicit

Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" ( _
    ByVal lpClassName As String, _
    ByVal lpWindowName As String) As Long
Private Declare Function GetClassName Lib "user32.dll" Alias "GetClassNameA" ( _
    ByVal hwnd As Long, _
    ByVal lpClassName As String, _
    ByVal nMaxCount As Long) As Long
Private Declare Function GetWindowTextLength Lib "user32.dll" Alias "GetWindowTextLengthA" ( _
    ByVal hwnd As Long) As Long
Private Declare Function GetWindowText Lib "user32.dll" Alias "GetWindowTextA" ( _
    ByVal hwnd As Long, _
    ByVal lpString As String, _
    ByVal cch As Long) As Long
Private Declare Function GetWindow Lib "user32.dll" ( _
     ByVal hwnd As Long, _
     ByVal wCmd As Long) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" ( _
    ByVal hwnd As Long, _
    ByVal wMsg As Long, _
    ByVal wParam As Long, _
    ByVal lParam As Long) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
    ByVal dwMilliseconds As Long)

Private Const GC_CLASSNAME_ACROBATREADER = "AcrobatSDIWindow"
Private Const GW_HWNDNEXT = 2
Private Const WM_CLOSE = &H10

Public Sub ClosePDF(ByVal pvstrFilname As String)

    Const PDF_CAPTION = " - Adobe Reader"

    Dim lngHwnd As Long, lngReturn As Long
    Dim strTitle As String, strClassName As String * 256
    Dim strCaption As String


    strTitle = Mid$(pvstrFilname, InStrRev(pvstrFilname, "\") + 1) & PDF_CAPTION

    lngHwnd = FindWindow(vbNullString, vbNullString)

    Do While lngHwnd <> 0

        lngReturn = GetClassName(lngHwnd, strClassName, 256)

        If Left$(strClassName, lngReturn) = GC_CLASSNAME_ACROBATREADER Then

            lngReturn = GetWindowTextLength(lngHwnd)
            strCaption = Space$(lngReturn)
            Call GetWindowText(lngHwnd, strCaption, lngReturn + 1)

            If strCaption = strTitle Then

                Call PostMessage(lngHwnd, WM_CLOSE, 0&, 0&)
                Call Sleep(500)
                Exit Do

            End If

        End If

        lngHwnd = GetWindow(lngHwnd, GW_HWNDNEXT)

    Loop
End Sub

in ein Modul (bei mir Modul 5) gepackt.

In der Prozedur soll ja der Code

Code:

Private Sub cmdExportieren_Click()

    Dim strName As String

    strName = ThisWorkbook.Path & "\" & Worksheets("Einstellungen").Range("A14").Value & ".pdf"

    Call ClosePDF(strName)

    ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strName, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=True, From:=1, To:=1

    Unload Me

End Sub

untergebracht werden. Angepasst dachte ich mir eigentlich den Code für meinen Button so...

Code:

Dim pdfName As Variant, DtTxt As String, UserTxt As String

    DtTxt = Format(Date, "DD-MM-YYYY")
    UserTxt = Application.UserName

pdfName = Application.GetSaveAsFilename(Environ("USERPROFILE") & "\Desktop\" & "Liste alle offenen Verfahren - Wohn L" & "_" & DtTxt & "_" & UserTxt & ".pdf", "PDF-Dateien (*.pdf), *.pdf")

Call ClosePDF(pdfName)

If pdfName <> False Then
Sheets("Listen_Wohn L").ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfName, _
                          Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintareas:=False, _
                          OpenAfterPublish:=True, From:=1, To:=1
End If

aber bei der Ausführung bleibt er wieder bei "Sheets" hängen. Adobe wird nicht geschlossen und es kommt der Laufzeitfehler.

Schon jetzt Danke für Deine/Eure Geduld!
Grüße

[Steffl]

Hallo,

das dürfte daran liegen, das die Datei schon existiert.

Code:

Dim pdfName As Variant, DtTxt As String, UserTxt As String

DtTxt = Format(Date, "DD-MM-YYYY")
UserTxt = Application.UserName

If Dir(Environ("USERPROFILE") & "\Desktop\" & "Liste alle offenen Verfahren - Wohn L" & "_" & DtTxt & "_" & UserTxt & ".pdf") = "" Then
   pdfName = Application.GetSaveAsFilename(Environ("USERPROFILE") & "\Desktop\" & "Liste alle offenen Verfahren - Wohn L" & "_" & DtTxt & "_" & UserTxt & ".pdf", "PDF-Dateien (*.pdf), *.pdf")
  
  
   'Call ClosePDF(pdfName)
  
   If pdfName <> False Then
      Sheets("Listen_Wohn L").ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdfName, _
                             Quality:=xlQualityStandard, IncludeDocProperties:=False, IgnorePrintareas:=False, _
                             OpenAfterPublish:=True, From:=1, To:=1
   End If
Else
   MsgBox " Die Datei existiert schon", vbInformation

End If

[sandormiles]

Hach Stefan... Meine Rettung !!! Danke

[sandormiles]

Hallo zusammen...

Könnte ihr bitte über den Code mal rüberschauen, ob euch Fehler auffallen oder Verbesserungen. Ist nicht mein Code, aber der hat ja schon einige Jahre auf dem Buckel und vielleicht würde man/ihr das heute anders schreiben?

Vielleicht kurz, was erreicht werden soll. Auf meine UserForm werden mehrere Benutzer Zugriff haben. Nicht gleichzeitig, also ist es notwendig die UserForm nach Inaktivität (z.B. 5 Minuten) zuschließen und vorab eine kurze Warnmeldung einzublenden. Entweder wird auf die Warnmeldung reagiert, also der Timer zum Schließen auf einen Button zurückgesetzt oder falls man nicht reagiert, schließt die UserForm. Die UserForm mit der Warnmeldung ist bei mir die UserForm999 und hat zwei Button. Einen mit "Nein", also nicht schließen und einen mit "Datei schließen."

Der Code für "DieseArbeitsmappe"

Code:

Option Explicit
'   erstellt von Hajo.Ziplies@web.de 28.12.03
'   http://home.media-n.de/ziplies/

Private Sub Workbook_Open()
   Zeitmakro
   UserForm1.Show
   
End Sub

Private Sub Workbook_BeforeClose(Cancel As Boolean)
   On Error Resume Next
   Application.OnTime EarliestTime:=ET, Procedure:="Start", Schedule:=False
   Application.OnTime EarliestTime:=ET1, Procedure:="Schließen", Schedule:=False
End Sub

Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
   Application.OnTime EarliestTime:=ET, Procedure:="Start", Schedule:=False
   Zeitmakro
End Sub

Der Code für "Modul"

Code:

Option Explicit
'   erstellt von Hajo.Ziplies@web.de 28.12.03 abgeändert von Nepumuk 23.05.2004
'   http://home.media-n.de/ziplies/

Public Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Public Declare Function SetWindowPos Lib "User32" (ByVal hWnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Declare Function SetActiveWindow Lib "user32.dll" (ByVal hWnd As Long) As Long

Public Enum Parameter
   HWND_TOPMOST = -1
   SWP_NOSIZE = &H1
   SWP_NOMOVE = &H2
   SWP_NOACTIVATE = &H10
   SWP_SHOWWINDOW = &H40
End Enum

Public ET As Variant
Public ET1 As Variant
Public BoZu As Boolean

Declare Function Ton& Lib "kernel32" _
Alias "Beep" _
(ByVal dwFrequenz As Long, _
 ByVal dwDauer As Long)
 
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)





Sub Zeitmakro()
   BoZu = False
   On Error Resume Next
   Application.OnTime EarliestTime:=ET1, Procedure:="Zeitmakro", Schedule:=False
   ET = Now + TimeValue("00:00:15")
   Application.OnTime ET, "Start"
   
End Sub


Sub Start()
   ET1 = Now + TimeValue("00:00:10")
   Application.OnTime ET1, "Schließen"
   SetActiveWindow FindWindow("xlMain", vbNullString)
   UserForm999.Show
End Sub

Sub Schließen()
   Unload UserForm999
   If BoZu = False Then
       'ThisWorkbook.Save 'vor schliessen wird gespeichert
       If Workbooks.Count = 1 Then Application.Quit Else ThisWorkbook.Close
   End If
End Sub

Der Code für "UserForm"

Code:

Option Explicit
'   erstellt von Hajo.Ziplies@web.de 28.12.03
'   http://home.media-n.de/ziplies/
Dim Uhrzeit
   
   'ANFANG UserForm ohne Schliessen_Kreuz
   Private Const GWL_STYLE = (-16)
   Private Const WS_SYSMENU = &H80000
   Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
   Private Declare Function GetWindowLong Lib "User32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long
   Private Declare Function SetWindowLong Lib "User32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
   Private Declare Function DrawMenuBar Lib "User32" (ByVal hWnd As Long) As Long
   'ENDE UserForm ohne Schliessen_Kreuz
   

Private Sub UserForm_Activate()

   'ANFANG UserForm ohne Schliessen_Kreuz
   Dim xl_hwnd, lStyle
   xl_hwnd = FindWindow(vbNullString, Me.Caption)
   If xl_hwnd <> 0 Then
       lStyle = GetWindowLong(xl_hwnd, GWL_STYLE)
       lStyle = SetWindowLong(xl_hwnd, GWL_STYLE, lStyle And Not WS_SYSMENU)
       DrawMenuBar xl_hwnd
   End If
   'ENDE UserForm ohne Schliessen_Kreuz

   Dim I, GeöffneteFormulare
   
   BoZu = False
   SetWindowPos FindWindow(vbNullString, Me.Caption), HWND_TOPMOST, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOMOVE Or SWP_NOACTIVATE Or SWP_SHOWWINDOW
   Uhrzeit = Now + TimeValue("0:00:01")
   Do
       For I = 1 To 100    ' Schleifenanfang.
           If I Mod 100 = 0 Then     ' Nach 100 Durchläufen Steuerung
               GeöffneteFormulare = DoEvents    ' an das Betriebssystem abgeben.
           End If
       Next I    ' Schleifenzähler hochzählen.
   
           
   Loop Until Now > Uhrzeit + TimeValue("0:00:05")

End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
'   Damit mit X nicht geschloßen werden kann
   If CloseMode = 0 Then
       MsgBox "Bitte schließen Sie die Anwendung mit der -Ende- Schaltfläche.", vbCritical
       Cancel = 1
   End If
End Sub

Private Sub CMD_Nein_Click()
   Uhrzeit = Uhrzeit - TimeValue("0:00:05")
   Application.OnTime EarliestTime:=ET1, Procedure:="Schließen", Schedule:=False
   BoZu = True
   Zeitmakro
   Me.Hide
End Sub



Private Sub Cmd_Schliessen_Click()
'   nach Hinweis von Nepumuk ergänzt
   Schließen
End Sub

Was mir zum Beispiel schon aufgefallen ist, dass bisweilen, konnte es noch nicht nachstellen, von Excel noch die Nachfrage kommt, ob die Datei gespeichert werden soll oder nicht. Die Meldung sollte irgendwie nicht kommen, sonst läuft das mit dem automatischen schließen ja ins Leere, wenn der Nutzer nicht vor dem Rechner sitzt.

Danke schon jetzt und Grüße

[Steffl]

Hallo,

da es sich um ein neues Problem handelt solltest Du ein neues Thema eröffnen.

[sandormiles]

Alles klar, wird gemacht und an der Stelle für die Hilfe noch mal ein ganz großes Dankeschön!

[sandormiles]

Einen habe ich doch noch...

Nun will ich ein Handbuch (PDF) per Button aufrufbar machen. Gefunden habe ich den nachfolgenden und auf meine Datei schon angepassten Code. Das Aufrufen der Datei klappt soweit auch. Bei Abbrechen bleibt er bei ActiveWorkbook... mit einem Laufzeitfehler hängen. Es kommt der Fehler 287 "Anwendungs- oder objektdefinierter Fehler". Die Onlinehilfe ist nicht wirklich hilfreich...

Code:

Sub OeffnePDF()

Dim Datei As String
Datei = "\HiDrive\Dokumente\VBARecht\Handbuch_VBA_WohnRecht.pdf"
ActiveWorkbook.FollowHyperlink Datei

End Sub

Grüße zum Abend
Sandor

[schauan]

Hallöchen,
Hilft eventuell Application.DisplayAlerts=False ?