Option Explicit
Public Pt As Variant, ws As Worksheet, ws2 As Worksheet, C As Range, Zähler As Long, wb As Workbook, _
Start As Long, Preis As String, Fehlermeldung As String, Zeit As Long
Private Declare Function GetDesktopWindow Lib user32 () As Long
Private Declare Function GetWindow Lib user32 (ByVal hWnd As Long, ByVal wCmd As Long) As Long
Private Declare Function GetWindowLong Lib user32 Alias GetWindowLongA (ByVal hWnd As Long, ByVal wIndx As Long) As Long
Private Declare Function GetWindowTextLength Lib user32 Alias GetWindowTextLengthA (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 GetParent Lib user32 (ByVal hWnd As Long) As Long
Private Declare Function GetWindowThreadProcessId Lib user32 (ByVal hWnd As Long, lpdwProcessId As Long) As Long
Const GW_HWNDFIRST = 0: Const GW_HWNDLAST = 1: Const GW_HWNDNEXT = 2: Const GW_HWNDPREV = 3
Const GW_OWNER = 4: Const GW_CHILD = 5: Const GW_MAX = 5: Const GWL_STYLE = (-16): Const WS_VISIBLE = &H10000000
Const WS_BORDER = &H800000: Dim proghwnd() As Long, progtitel() As String
Private Function ReturnAPPTitle(param As String) As String
Dim hWnd&: ReDim Preserve proghwnd(1): ReDim Preserve progtitel(1)
->Auch der Desktop ist ein Fenster
hWnd = GetDesktopWindow
Call GetWindowInfo(hWnd)
->Einstieg
hWnd = GetWindow(Application.hWnd, GW_HWNDFIRST)
->Alle vorhandenen Fenster abklappern
Do
Call GetWindowInfo(hWnd)
hWnd = GetWindow(hWnd, GW_HWNDNEXT)
Loop Until hWnd = 0
Dim i As Long
For i = 1 To UBound(proghwnd)
If UCase(progtitel(i)) Like UCase(param) Then
->MsgBox proghwnd(I)
ReturnAPPTitle = progtitel(i)
End If
Next
End Function
Sub GetWindowInfo(ByVal hWnd&)
Dim Parent&, Task&, Result&, X&, Style&, Title$
->Darstellung des Fensters
Style = GetWindowLong(hWnd, GWL_STYLE)
Style = Style And (WS_VISIBLE Or WS_BORDER)
->Title des Fenster auslesen
Result = GetWindowTextLength(hWnd) + 1
Title = Space$(Result)
Result = GetWindowText(hWnd, Title, Result)
Title = Left$(Title, Len(Title) - 1)
If Trim(Title) <> Then
ReDim Preserve proghwnd(UBound(proghwnd) + 1)
ReDim Preserve progtitel(UBound(proghwnd) + 1)
proghwnd(UBound(proghwnd)) = hWnd
progtitel(UBound(proghwnd)) = Title
->Debug.Print progtitel(UBound(progtitel))
End If
->Elternfenster ermitteln
Parent = hWnd
Do
Parent = GetParent(Parent)
Loop Until Parent = 0
->Task Id ermitteln
Result = GetWindowThreadProcessId(hWnd, Task)
End Sub
Sub Start_AS()
Set wb = ActiveWorkbook: Set ws = wb.Sheets(1)
ws.Name = Daten
Pt = ReturnAPPTitle(*sitzung a*)
If wb.Sheets.Count < 2 Then
Sheets.Add , wb.Sheets(1)
ActiveSheet.Name = Knecht
Set ws2 = wb.Sheets(Knecht)
Set C = ws.Cells
Else
wb.Sheets(2).Name = Knecht
Set ws2 = wb.Sheets(Knecht)
Set C = ws.Cells
End If
Start = Timer
ws.Activate
ws.Range(C(2, 2), C(C(65536, 2).End(xlUp).Row, 2)).NumberFormat = 0.000
AppActivate Pt, True
Application.Wait (Now + TimeValue(00:00:04))
For Zähler = 2 To C(65536, 1).End(xlUp).Row
Sprungmarke:
Application.Wait (Now + TimeValue(00:00:02))
Application.SendKeys {DOWN}, True
Application.SendKeys {HOME}, True
C(Zähler, 1).Copy
Application.SendKeys c, True->C (im Standardmodus AS400 ist belegt mit Einfügen)
Application.SendKeys {TAB}, True
Preis = Format(C(Zähler, 2).Value, 0.000)
Application.SendKeys (Preis), True
Application.SendKeys e, True
Application.Wait (Now + TimeValue(00:00:01))
ws2.Range(ws2.Cells(1, 1), ws2.Cells(ws2.UsedRange.Rows.Count, ws2.UsedRange.Columns.Count)).EntireColumn.Delete
Application.SendKeys y, True->Y (im Standardmodus AS400 ist belegt mit Kopieren)
ws2.Paste Destination:=ws2.Range(A1)
Fehlermeldung = ws2.Cells(21, 1).Value
Select Case (Fehlermeldung)
Case Artikel ungültig wegen Lösch-Kennzeichen
C(Zähler, 3).Value = Artikel ist gelöscht
GoTo Fehler
Case Datensatz bereits vorhanden!
C(Zähler, 3).Value = Datensatz bereits vorhanden!
GoTo Fehler
Case Artikel fehlt in Lagerstammdatei
C(Zähler, 3).Value = falsche ArtNr
GoTo Fehler
Case Maximal zulässigen Preis überschritten!
C(Zähler, 3).Value = Preisstellung prüfen!
GoTo Fehler
Case Bitte Preis vorgeben!
C(Zähler, 3).Value = Kein Preis eingetragen!
GoTo Fehler
Case Artikel fehlt in Artikelstammdatei
C(Zähler, 3).Value = ArtikelNr falsch
GoTo Fehler
Case Is <>
C(Zähler, 3).Value = Unbekannter Fehler, bitte prüfen!
GoTo Fehler
Case Else
GoTo Weiter
End Select
Fehler:
Application.SendKeys {Return}, True
Application.SendKeys {Return}, True
Application.Wait (Now + TimeValue(00:00:05))
Weiter:
Next Zähler
Zeit = Timer - Start
MsgBox Preispflege beendet. & Chr(13) & Chr(13) & _
Die Prozedur dauerte: & Format(Zeit / 60, 00) & Minuten & Format(Zeit Mod 60, 00) & Sekunden
End Sub
