AW: Datum mit aktuellerem Datum überschreiben ?
28.12.2018 16:57:35
Nepumuk
Hallo Alexander,
teste mal:
Option Explicit
Private Declare Function FindWindowA Lib "user32.dll" ( _
ByVal lpClassName As String, _
ByVal lpWindowName As String) As Long
Private Declare Function SetTimer Lib "user32.dll" ( _
ByVal Hwnd As Long, _
ByVal nIDEvent As Long, _
ByVal uElapse As Long, _
ByVal lpTimer As Long) As Long
Private Declare Function KillTimer Lib "user32.dll" ( _
ByVal Hwnd As Long, _
ByVal nIDEvent As Long) As Long
Private Declare Function MessageBoxA Lib "user32.dll" ( _
ByVal Hwnd As Long, _
ByVal lpText As String, _
ByVal lpCaption As String, _
ByVal wType As Long) As Long
Private Declare Function SendDlgItemMessageA Lib "user32.dll" ( _
ByVal hDlg As Long, _
ByVal nIDDlgItem As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As String) As Long
Private Declare Sub Sleep Lib "kernel32.dll" ( _
ByVal dwMilliseconds As Long)
Private Const TIMER_ID As Long = 0
Private Const TIMER_ELAPSE As Long = 25
Private Const WM_SETTEXT As Long = &HC
Private Const GC_CLASSNAMEDIALOGS As String = "#32770"
Private lstrButtonCaption1 As String
Private lstrButtonCaption2 As String
Private lstrButtonCaption3 As String
Private lstrBoxTitel As String
Private Function MsgBoxPlus( _
ByVal pvstrText As String, _
ByVal pvstrTitle As String, _
ByVal pvstrButtonText1 As String, _
Optional ByVal opvstrButtonText2 As String, _
Optional ByVal opvstrButtonText3 As String, _
Optional ByVal oenmStyle As VbMsgBoxStyle = vbInformation) As Long
Dim enmResult As VbMsgBoxResult
lstrButtonCaption1 = pvstrButtonText1
lstrButtonCaption2 = opvstrButtonText2
lstrButtonCaption3 = opvstrButtonText3
lstrBoxTitel = pvstrTitle
Call SetTimer(Application.Hwnd, TIMER_ID, TIMER_ELAPSE, AddressOf SetButtonText)
If lstrButtonCaption2 = "" And lstrButtonCaption3 = "" Then
enmResult = MessageBoxA(Application.Hwnd, pvstrText, pvstrTitle, vbOKOnly Or oenmStyle)
ElseIf lstrButtonCaption2 <> "" And lstrButtonCaption3 = "" Then
enmResult = MessageBoxA(Application.Hwnd, pvstrText, pvstrTitle, vbYesNo Or oenmStyle)
Else
enmResult = MessageBoxA(Application.Hwnd, pvstrText, pvstrTitle, vbAbortRetryIgnore Or oenmStyle)
End If
If enmResult = vbOK Or enmResult = vbYes Or enmResult = vbAbort Then
MsgBoxPlus = 1
ElseIf enmResult = vbNo Or enmResult = vbRetry Then
MsgBoxPlus = 2
Else
MsgBoxPlus = 3
End If
End Function
Private Sub SetButtonText()
Dim lngBox_hWnd As Long
Call KillTimer(Application.Hwnd, TIMER_ID)
lngBox_hWnd = FindWindowA(GC_CLASSNAMEDIALOGS, lstrBoxTitel)
If lstrButtonCaption2 = "" And lstrButtonCaption3 = "" Then
Call SendDlgItemMessageA(lngBox_hWnd, vbCancel, WM_SETTEXT, 0&, lstrButtonCaption1)
ElseIf lstrButtonCaption2 <> "" And lstrButtonCaption3 = "" Then
Call SendDlgItemMessageA(lngBox_hWnd, vbYes, WM_SETTEXT, 0&, lstrButtonCaption1)
Call SendDlgItemMessageA(lngBox_hWnd, vbNo, WM_SETTEXT, 0&, lstrButtonCaption2)
Else
Call SendDlgItemMessageA(lngBox_hWnd, vbAbort, WM_SETTEXT, 0&, lstrButtonCaption1)
Call SendDlgItemMessageA(lngBox_hWnd, vbRetry, WM_SETTEXT, 0&, lstrButtonCaption2)
Call SendDlgItemMessageA(lngBox_hWnd, vbIgnore, WM_SETTEXT, 0&, lstrButtonCaption3)
End If
End Sub
Private Function CallMsgBox( _
ByVal pvstrText As String, _
ByVal pvstrTitle As String, _
Optional opvenmStyle As VbMsgBoxStyle = vbInformation) As Long
CallMsgBox = MsgBoxPlus(pvstrText:=pvstrText, pvstrTitle:=pvstrTitle, _
pvstrButtonText1:="Weiter", opvstrButtonText2:="Mail", _
opvstrButtonText3:=vbNullString, oenmStyle:=opvenmStyle)
End Function
Private Sub Mail( _
ByVal pvstrName As String, _
ByVal pvstrMail1 As String, _
ByVal pvstrMail2 As String)
Dim objOutookApp As Object, objMail As Object
Set objOutookApp = CreateObject(Class:="Outlook.Application")
Set objMail = objOutookApp.CreateItem(0)
With objMail
.To = pvstrMail1 & "; " & pvstrMail2
.Subject = "Testmail"
.Body = "Hier kommt dein Text" & vbLf & vbLf & pvstrName & vbLf & vbLf & "Gruß Alexander"
.Display
End With
Set objMail = Nothing
Set objOutookApp = Nothing
End Sub
Public Sub WarningQualification()
Dim objCell As Range
Dim strFirstAddress As String
With ThisWorkbook.Worksheets("AuswertungDatum").Columns(9)
Set objCell = .Find(What:=5, After:=.Cells(1, 1), _
LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=False)
If Not objCell Is Nothing Then
strFirstAddress = objCell.Address
Do
If CallMsgBox(pvstrText:="Mitarbeiter ''" & objCell.Offset(0, -5).Text & _
"'' hat 3 Monate nicht an der Anlage ''" & _
objCell.Offset(0, -7).MergeArea.Cells(1).Value & _
"'' gearbeitet und wurde deaktiviert, TRAINING VERANLASSEN !!", _
pvstrTitle:="Hinweis", opvenmStyle:=vbExclamation) = 2 Then _
Call Mail(pvstrName:=objCell.Offset(0, -5).Text, _
pvstrMail1:=Cells(1, 10).Text, pvstrMail2:=Cells(2, 10).Text)
Set objCell = .FindNext(After:=objCell)
Loop Until objCell.Address = strFirstAddress
Set objCell = Nothing
End If
End With
End Sub
Gruß
Nepumuk