Makro ergibt jedes zweite Mal Fehler
13.06.2007 09:17:19
Sven
Ich habe ein merkwürdiges Problem: mein Makro läuft, direkt nachdem ich Excel geöffnet habe, beim ersten Durchgang fehlerfrei. Wenn ich es danach aber erneut starten will, kommt ein Fehler. Der dritte Versuch klappt dann wieder, der vierte scheitert, usw...
Beschreibung des Makros:
Es befindet sich in einem allgemeinen Modul.
Zunächst wählt der Anwender im Auswahlfenster eine pdf-Datei aus, die darauf geöffnet wird. Nach dem Öffnen-Befehl prüft eine Schleife alle momentan offenen Windows-Fenster und sobald das entsprechende Acrobat-Reader Fenster gefunden wurde, läuft das Makro weiter. Mit der SendKeys-Methode wird dann der Text der pdf-Datei per copy&paste ins Excel-Sheet kopiert und das Acrobat-Fenster geschlossen.
Danach wird nur noch der Text den eigenen Belangen nach verarbeitet.
Hier ist der Code:
Option Explicit
Public Declare Function GetWindow Lib "user32" (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, _
ByVal wIndx As Long) As Long
Public Declare Function GetWindowTextLength Lib "user32" Alias "GetWindowTextLengthA" (ByVal _
hWnd As Long) As Long
Public Declare Function GetWindowText Lib "user32" Alias "GetWindowTextA" (ByVal hWnd As Long, _
ByVal lpString As String, ByVal cch As Long) As Long
Public Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As Long, _
ByVal lpWindowName As Long) As Long
Public Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hWnd As Long, ByVal lpOperation As String, _
ByVal lpFile As String, ByVal lpParameters As String, _
ByVal lpDirectory As String, ByVal nShowCmd As Long) As Long
Const GW_HWNDFIRST = 0
Const GW_HWNDNEXT = 2
Const GWL_STYLE = (-16)
Const WS_VISIBLE = &H10000000
Const WS_BORDER = &H800000
Public Task_name() As String, Count As Integer
Public Sub GetWindowList()
Dim hWnd As Long, sTitle As String, lStyle As Long
Dim index As Integer, gefunden As Boolean
hWnd = FindWindow(ByVal 0&, ByVal 0&)
hWnd = GetWindow(hWnd, GW_HWNDFIRST)
Do
gefunden = False
lStyle = GetWindowLong(hWnd, GWL_STYLE)
lStyle = lStyle And (WS_VISIBLE Or WS_BORDER)
sTitle = GetWindowTitle(hWnd)
If (lStyle = (WS_VISIBLE Or WS_BORDER)) = True Then
If Trim(sTitle) "" Then
sTitle = Mid(sTitle, 1, Len(sTitle))
For index = 1 To Count
If Task_name(index) = sTitle Then
gefunden = True
Exit For
End If
Next index
If Not gefunden Then
Count = Count + 1
ReDim Preserve Task_name(1 To Count)
Task_name(Count) = sTitle
End If
End If
End If
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop Until hWnd = 0
End Sub
Public Function GetWindowTitle(ByVal hWnd As Long) As String
Dim lResult As Long, sTemp As String
lResult = GetWindowTextLength(hWnd) + 1
sTemp = Space(lResult)
lResult = GetWindowText(hWnd, sTemp, lResult)
GetWindowTitle = Left(sTemp, Len(sTemp) - 1)
End Function
Sub CommandButton1_Klick()
Dim Wert, Wertlänge, k, Wertrechts, Slash, Wertname
Dim var As Variant
Dim icounter As Integer
Range("B3").Value = ""
Range("B5").Value = ""
Range("B3").Select
var = Application.GetOpenFilename("Alle-Dateien (*.*),*.*,", MultiSelect:=True)
Dim Datei_mit_Pfad, Datei_ohne_Pfad
Datei_mit_Pfad = Array()
Datei_ohne_Pfad = Array()
For icounter = 1 To UBound(var)
Wert = var(icounter)
ReDim Preserve Datei_mit_Pfad(icounter - 1)
Datei_mit_Pfad(icounter - 1) = Wert
Wertlänge = Len(Wert)
For k = 1 To Wertlänge
Wertrechts = Right(Wert, k)
Slash = Left(Wertrechts, 1)
Select Case Slash
Case Is = "\"
Wertname = Right(Wert, k - 1)
ReDim Preserve Datei_ohne_Pfad(icounter - 1)
Datei_ohne_Pfad(icounter - 1) = Wertname
k = Wertlänge
End Select
Next k
Next icounter
Dim n
For n = 0 To UBound(var) - 1
Dim Fenster1
Application.ScreenUpdating = False
Fenster1 = ActiveWorkbook.Name
Cells(1, 1).Activate
ShellExecute Application.hWnd, "Open", Datei_mit_Pfad(n), vbNullString, vbNullString, _
vbNormalFocus
Dim newHour, newMinute, newSecond, waitTime
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 1
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime
Dim index, i
Line1:
Do
GetWindowList
For index = 1 To Count
If InStr(1, Task_name(index), Datei_ohne_Pfad(n)) 0 Then
Exit Do
End If
Next
Loop
Dim WshShell
On Error GoTo Line1
AppActivate Task_name(index)
Set WshShell = CreateObject("WScript.Shell")
SendKeys ("^a"), Wait:=True
SendKeys ("^c"), Wait:=True
SendKeys ("%{F4}"), Wait:=True
AppActivate Fenster1
Cells(101, 1).Select
SendKeys ("^v"), Wait:=True
On Error GoTo 0
Dim Preis As Long, Beschreibung
Preis = Left((Right(Cells(159, 1), Len(Cells(159, 1)) - 20)), Len(Right(Cells(159, 1), Len( _
Cells(159, 1)) - 20)) - 7)
Beschreibung = Trim(Right(Range("A:A").Find("Projekt:"), Len(Range("A:A").Find("Projekt:")) - _
InStr(1, Range("A:A").Find("Projekt:"), ":")))
Range(Cells(100, 1), Cells(1000, 1)).ClearContents
Dim strTmp As String
Dim arrTmp As Variant
strTmp = Replace(Datei_ohne_Pfad(n), ".", "_")
arrTmp = Split(strTmp, "_")
Range("C21").Value = Beschreibung
Range("I21").Value = Preis 'Betrag
Range("G21").Value = arrTmp(1) 'Best-Nr.
Range("H21").Value = arrTmp(2) 'Firma
Range("A21").Value = Right(arrTmp(3), 2) & "." & Mid(arrTmp(3), 5, 2) & "." & Left(arrTmp(3), 4) _
'Datum
Application.ScreenUpdating = True
Next n
End Sub
Wie gesagt, nach jedem erfolgreichen Durchlauf, folgt ein Fehler:
Laufzeitfehler 5:
Ungültiger Prozeduraufruf oder ungültiges Argument
markiert wird diese Stelle: AppActivate Task_name(index)
Ich vermute, dass nach dem Abbruch durch den Fehler das Array oder irgendwas anderes zurückgesetzt wird, sodass es beim nächsten Mal dann immer wieder klappt, aber ich weiß nicht, wie man das prüfen kann und auch nicht, wie man es selbst machen könnte.
Ist jemand so lieb und wirft mal einen Blick drüber?
Dankeschön.