Makro mit API-MsgBox beenden
25.12.2014 22:19:03
Golem
ich benötige wieder Eure Hilfe.
Mit folgendem Makro positioniere ich eine API-MsgBox auf einem Excel-Fenster ( nicht von mir, nur angepasst ).
Option Explicit
' Entfernt eine Hook-Prozedur in einer Hook-Kette von der installierten SetWindowsHookEx Funktion.
Private Declare Function UnhookWindowsHookEx Lib "user32" _
(ByVal hHook As Long) As Long
' Wird die Identität des aktuell ausgeführten Thema zurückkehren.
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
' Installiert eine anwendungsdefinierte Hook-Prozedur in eine Hook-Kette.
Private Declare Function SetWindowsHookEx Lib "user32" _
Alias "SetWindowsHookExA" _
(ByVal idHook As Long, _
ByVal lpfn As Long, _
ByVal hmod As Long, _
ByVal dwThreadId As Long) _
As Long
' Die API-Funktion SetWindowPos positioniert, zeigt und versteckt Fenster.
Private 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
' Deklaration: Globale Form API-Konstanten
Private Const SWP_NOSIZE As Long = &H1 ' verhindert, dass das Fenster eine neue Größe bekommt.
Private Const SWP_NOZORDER As Long = &H4 ' verhindert, dass die Z-Order-Position verändert wird.
' Hakentypen, um ein neues Fenster zu erkennen
Private Const WH_CBT = 5 ' Installiert eine Hook-Prozedur.....
Private Const HCBT_ACTIVATE = 5 ' Das System ist dabei, ein Fenster zu aktivieren....
' Griff in die Hook-Prozedur
Private hHook As Long
' Position
Private msgbox_x As Long
Private msgbox_y As Long
Sub Pos_API_MsgBox()
Dim fb As Integer
fb = ActiveWindow.Width 'gesamte Fensterbreite in Pixel.....
MsgBoxPos " Sollen die Umsätze weiter eingelesen werden ?", vbYesNo _
"Für Abbruch bitte Nein betätigen", _
(fb + 313) / 2 - (305 / 2), 430 ' halbe Fensterbreite minus halbe MsgBox, von oben 430 Pixel.....
End Sub
Public Sub MsgBoxPos(strPromt As String, _
vbButtons As VbMsgBoxStyle, _
strTitle As String, _
xPos As Long, _
yPos As Long)
' Position speichern
msgbox_x = xPos
msgbox_y = yPos
' Installiert eine anwendungsdefinierte Hook-Prozedur in einer Hook-Kette.
hHook = SetWindowsHookEx(WH_CBT, AddressOf MsgBoxHookProc, 0, GetCurrentThreadId)
' Run MessageBox
MsgBox strPromt, vbButtons, strTitle
End Sub
Private Function MsgBoxHookProc(ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long
If lMsg = HCBT_ACTIVATE Then
' Position ändern
SetWindowPos wParam, 0, msgbox_x, msgbox_y, 0, 0, SWP_NOSIZE + SWP_NOZORDER
' SetWindowPos wParam, 0, 0, 0, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
' SetWindowPos wParam, 0, x, y, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE
' Lassen Sie den Haken
UnhookWindowsHookEx hHook
End If
MsgBoxHookProc = False
End Function
Nach einem jeweiligen einzelnen Schleifendurchlauf , soll durch die Betätigung der der Ja-Taste, ein weiterer Schleifendurchlauf
erfolgen ( bis zum Schleifende lngEnd = Range("I38") )
Durch die Betätigung der Nein-Taste möchte ich mit G0To DispFehler nach jedem Schleifendurchlauf
den Code beenden können.
Private Sub CommandButton55_Click()
Dim strPath As String
Dim objWorkbook As Workbook
Dim fso As Object
Dim byWert As Byte
' For-Next-Schleife mit numerische Variablen.....
Dim lngIndex As Long
' Start-, Endwert und Schritt variabel.....
Dim lngStart As Long
Dim lngEnd As Long
'Dim lngStep As Long
' Bei einer On Error-Anweisung, führt jeder Laufzeitfehle
' zur Anzeige einer Fehlermeldung und zum Beenden des Programms.
' GoTo aktiviert die Fehlerbehandlungsroutine.
On Error GoTo DispFehler
' Mit dem FSO-Modell können Informationen zu Ordnern abgerufen werden,
' z. B. der Name oder das Erstellungs- bzw. Änderungsdatum
' und auch die Anzahl der Dateien im Ordner.
' Mit der CreateObject-Methode, wird ein FileSystemObject-Objekt erstellt.
Set fso = CreateObject("Scripting.FileSystemObject")
If Range("D39") = False Then _
lngStart = Range("F38")
lngEnd = Range("I38")
'If Range("D39") = True Then _
'Range("F38") = ""
'Rang'lngStart = 1
'lngEnd = fso.GetFolder(ActiveWorkbook.Path & "\Umsatz ET").Files.Count - 8 ' _
mit GetFolder, wird ein Ordner aufgerufen.....
For lngIndex = lngStart To lngEnd
' Die Bildschirmaktualisierung wird abgeschaltet.
' Das verhindert einen flackernden Bildschirm und beschleunigt damit den VBA-Code.
Application.ScreenUpdating = False
strPath = FindFile(ActiveWorkbook.Path, CStr("Whn " & lngIndex & ".xlsm"))
If strPath vbNullString Then
Set objWorkbook = Workbooks.Open(Filename:=strPath)
Else
MsgBox "Datei nicht" & vbCrLf & "gefunden!", vbExclamation, " Es tut mir leid!"
End If
' Application.Run führt ein VBA-Makro aus. Der Makroname-Parameter besteht
' aus Dateiname mit Erweiterung, Code Name Tabellenblatt und Button.
Application.Run "'Whn " & lngIndex & ".xlsm" & "'!Tabelle1.CommandButton1_Click"
' DisplayAlerts, was soviel heißt wie Warnung anzeigen.
' Wird dies auf false gesetzt, werden Warnungen unterdrück.
' Der Benutzer wird nicht aufgefordert, Änderungen zu speichern.
Application.DisplayAlerts = False
objWorkbook.Close True ' Datei wird gespeichert, während sie geschlossen wird.....
'If MsgBox("Weiter im Code?", vbYesNo) vbYes Then
Pos_API_MsgBox
If byWert 1 Then
GoTo DispFehler ' mit DispFehler wird der Code abgebrochen.....
End If
Next lngIndex
DispFehler:
Application.DisplayAlerts = True ' DisplayAlerts wird wieder eingeschaltet.....
Application.ScreenUpdating = True ' Die Bildschirmaktualisierung wird wieder _
eingeschaltet.....
End Sub
Mit der normalen MsgBox funktioniert der Weiterlauf und das Beenden mit folgender Abfrage:
'If MsgBox("Weiter im Code?", vbYesNo) vbYes Then
If byWert 1 Then
GoTo DispFehler ' mit DispFehler wird der Code abgebrochen.....
End If
einwandfrei.
Mit der API-MsgBox habe ich es wie folgt versucht:
Pos_API_MsgBox
If byWert 1 Then
GoTo DispFehler ' mit DispFehler wird der Code abgebrochen.....
End If
Aber damit kann ich nur ein Beenden erreichen, keinen Weiterlauf.
Für evtl. Tipps oder Anregungen schon mal besten Dank!
Werner