AW: MSGBox in Vordergrund von Excel unabhängig
22.10.2009 22:59:56
Excel
Hallo Rüdiger,
geht schon, ist aber etwas aufwändiger.
' **********************************************************************
' Modul: basA_Mail Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
Sub SendWith_OutLook()
Dim OLApp As Object, OMail As Object
Dim hWnd As Long
Set OLApp = CreateObject("Outlook.Application")
hWnd = FindWindowHandle("*Outlook*")
Set OMail = OLApp.CreateItem(0)
With OMail
.To = "try.to@guess.it"
.CC = ""
.BCC = ""
.Subject = "Test"
.Body = "Hallo!"
.Display
If CoolBox(hWnd, "Soll diese Mail versendet werden", _
"Frage", "Mail absenden", "Abbrechen", "", _
CoolBoxIcon.Question) = 1 Then
.Send
End If
End With
Set OMail = Nothing
Set OLApp = Nothing
End Sub
' **********************************************************************
' Modul: basC_MsgBox Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'src:= http://www.vbarchiv.net/tipps/tipp_687-komfortable-msgbox-mit-frei-editierbaren-buttons.html
' Benötigte API's für die Timer-Steuerung
Private Declare Function SetTimer Lib "user32" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimer As Long) As Long
Private Declare Function KillTimer Lib "user32" ( _
ByVal hWnd As Long, _
ByVal nIDEvent As Long) As Long
Private Const MY_NID = 88
Private Const MY_ELAPSE = 25 ' Wartezeit: 25 MSek.
' Benötigte API's für das Manipulieren der MsgBox
Private Declare Function MessageBox Lib "user32" _
Alias "MessageBoxA" ( _
ByVal hWnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) As Long
Private Declare Function GetActiveWindow Lib "user32" () As Long
Private Declare Function SendDlgItemMessage Lib "USER32.DLL" _
Alias "SendDlgItemMessageA" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) As Long
' Benötigte Konstanten
Private Const WM_SETTEXT = &HC
' MsgBox-Bildsymbole
Public Enum CoolBoxIcon
Critical = 16
Question = 32
Exclamation = 48
Information = 64
End Enum
' Variablen zur Speicherung der gewünschten
' Buttonbeschriftung
Private m_Caption1 As String
Private m_Caption2 As String
Private m_Caption3 As String
' WindowHandle
Private m_hWnd As Long
' MsgBox anzeigen
Public Function CoolBox(ByVal hWnd As Long, _
ByVal Text As String, _
ByVal Title As String, _
ByVal Button1 As String, _
Optional ByVal Button2 As String, _
Optional ByVal Button3 As String, _
Optional ByVal Symbol As CoolBoxIcon) As Long
Dim nResult As Long
' Fensterhandle
m_hWnd = hWnd
' Beschriftung der Buttons
m_Caption1 = Button1
m_Caption2 = Button2
m_Caption3 = Button3
' API-Timer starten
nResult = SetTimer(m_hWnd, MY_NID, MY_ELAPSE, _
AddressOf Coolbox_TimerEvent)
' API Message-Box mit gewünschter Buttonalzahl aufrufen
If Button2 = "" And Button3 = "" Then
' Ein Button
nResult = MessageBox(m_hWnd, Text, Title, _
Symbol Or vbOKOnly)
ElseIf Button2 <> "" And Button3 = "" Then
' Zwei Buttons
nResult = MessageBox(m_hWnd, Text, Title, _
Symbol Or vbYesNo)
Else
' Drei Buttons
nResult = MessageBox(m_hWnd, Text, Title, _
Symbol Or vbAbortRetryIgnore)
End If
' Antwort auswerten und Rückgabewert festlegen
If nResult = 1 Or nResult = 3 Or nResult = 6 Then
' erster Button wurde gedrückt
CoolBox = 1
ElseIf nResult = 4 Or nResult = 7 Then
' zweiter Button wurde gedrückt
CoolBox = 2
Else
' dritter Button wurde gedrückt
CoolBox = 3
End If
End Function
' Timer-Event!
Sub Coolbox_TimerEvent()
Dim nWnd As Long
' API-Timer wieder deaktivieren
KillTimer m_hWnd, MY_NID
' Fensterhandle der MsgBox
nWnd = GetActiveWindow()
' Buttons neu beschriften
If m_Caption2 = "" And m_Caption3 = "" Then
' nur ein Button
SendDlgItemMessage nWnd, vbCancel, WM_SETTEXT, 0, m_Caption1
ElseIf m_Caption2 <> "" And m_Caption3 = "" Then
' Zwei Buttons
SendDlgItemMessage nWnd, vbYes, WM_SETTEXT, 0, m_Caption1
SendDlgItemMessage nWnd, vbNo, WM_SETTEXT, 0, m_Caption2
Else
' Drei Buttons
SendDlgItemMessage nWnd, vbAbort, WM_SETTEXT, 0, m_Caption1
SendDlgItemMessage nWnd, vbRetry, WM_SETTEXT, 0, m_Caption2
SendDlgItemMessage nWnd, vbIgnore, WM_SETTEXT, 0, m_Caption3
End If
End Sub
' **********************************************************************
' Modul: basB_Handle Typ: Allgemeines Modul
' **********************************************************************
Option Explicit
'src:= http://www.vbarchiv.net/tipps/tipp_2012.html
' benötigte API-Deklarationen
Private Declare Function FindWindow Lib "user32" _
Alias "FindWindowA" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) 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 GetWindow Lib "user32" ( _
ByVal hWnd As Long, _
ByVal wCmd As Long) As Long
Private Const GW_HWNDNEXT = 2
' Ermittelt das Handle eines Fensters anhand dessen Fenstertitel
'
' sTitel: muss nicht der exakte Fenstertitel sein
' hier kann bspw. auch nur der Anfang des Fenstertitel
' angegeben werden, z.B.: Fenstertitel*
'
Public Function FindWindowHandle(ByVal sTitle As String) As Long
Dim lngHWnd As Long
Dim sText As String
' alle Fenster durchlaufen
lngHWnd = FindWindow(vbNullString, vbNullString)
Do While lngHWnd <> 0
' Fensterttitel ermitteln
sText = GetWindowTitle(lngHWnd)
If Len(sText) > 0 And LCase$(sText) Like LCase$(sTitle) Then
FindWindowHandle = lngHWnd: Exit Do
End If
' Nächstes Fenster
lngHWnd = GetWindow(lngHWnd, GW_HWNDNEXT)
Loop
End Function
' Hilfsfunktion zum Ermitteln des Fenstertitels
Public Function GetWindowTitle(ByVal hWnd As Long) As String
Dim lResult As Long
Dim sTemp As String
lResult = GetWindowTextLength(hWnd) + 1
sTemp = Space(lResult)
lResult = GetWindowText(hWnd, sTemp, lResult)
GetWindowTitle = Left(sTemp, Len(sTemp) - 1)
End Function
Gruß Sepp