Mit VBScript einfache Arbeitszeit berechnen. Mit Mittagspause

- 


' *******************************************************************************************  
' Arbeitszeitrechner  
'   
' erstellt: 10.04.2013 TSi   
' geändert: 17.05.2013 TSi - Freitagsanzeige angepasst | vbFriday  
' geändert: 29.05.2013 TSi/JB - Outlook Termin erstellen | Sub_OutlookTermin  
' geändert:   
' geändert:   
' *******************************************************************************************  
 
Option Explicit
' Registry Handling  
Const cHKCU = &h80000001
Const cHKLM = &h80000002
Const cHKCR = &h80000000
' File Handling  
Const cForReading = 1
Const cForWriting = 2
Const cForAppending = 8
Const cTristateUseDefault = -2
Const cTristateTrue = -1
Const cTristateFalse = 0
' DialogBox Handling  
Const cICON_STOP = 16 ' display the ERROR/STOP icon.  
Const cICON_QUESTION = 32 ' display the '?' icon  
Const cICON_WARN = 48 ' display a '!' icon.  
Const cICON_INFO =  64 ' displays "info" icon.  
Const cBUTTON_OK = 0 ' OK button only  
Const cBUTTON_CANCEL = 1 ' OK and Cancel buttons  
Const cBUTTON_ABORTRETRYIGNORE = 2 ' Abort, Retry, and Ignore buttons  
Const cBUTTON_YESNOCANCEL = 3 ' Yes, No, and Cancel buttons  
Const cBUTTON_YESNO = 4 ' Yes and No buttons  
Const cBUTTON_RETRYCANCEL = 5 ' Retry and Cancel buttons  
Const cDEFBUTTON1 = 0 ' First button is default  
Const cDEFBUTTON2 = 256 ' Second button is default  
Const cDEFBUTTON3 = 512 ' Third button is default  
Const cIDOK = 1 ' OK button clicked  
Const cIDCANCEL = 2 ' Cancel button clicked  
Const cIDABORT = 3 ' Abort button clicked  
Const cIDRETRY = 4 ' Retry button clicked  
Const cIDIGNORE = 5 ' Ignore button clicked  
Const cIDYES = 6 ' Yes button clicked  
Const cIDNO = 7 ' No button clicked  
' ADS Handling  
Const ADS_PROPERTY_CLEAR = 1
Const ADS_SCOPE_SUBTREE = 2

' Objekte anlegen  
Dim objShell, objFileSystem, objNetwork, objReg, szSystemroot
 
Set objShell = CreateObject("WScript.Shell")  
Set objFileSystem = CreateObject("Scripting.FileSystemObject")  
Set objNetwork = CreateObject("WScript.Network")  
Set objReg = GetObject("winmgmts:\\.\root\Default:StdRegProv")  
	
	' Start  
	Call Sub_Arbeitszeit()
	
' Objekte löschen  
WScript.DisconnectObject(objShell)
WScript.DisconnectObject(objFileSystem)
WScript.DisconnectObject(objNetwork)
WScript.DisconnectObject(objReg)
 
' Wscript.Sleep(1000)  
WScript.Quit	
	
'***************************************  
' Arbeitszeit  
'***************************************  
Sub Sub_Arbeitszeit()
	Dim dSollH, dSollHFr, dArbeitsBeginn, dPauseEnde, dPauseAnfang, dPausenlaenge, dAktuelleArbeitszeit, szFinalMessage, dSollerreicht, dZeitbisSoll, szUserChoice
	dSollH = TimeValue("7:30")  
	dSollHFr = TimeValue("6:00")  
	dArbeitsBeginn = InputBox(vbcrlf & vbcrlf & "Eingestempelt um ", "Arbeitszeit", "")  
	if dArbeitsBeginn = "" OR len(dArbeitsBeginn) < 3 then  
	else
		dArbeitsBeginn = GetTime(dArbeitsBeginn) ' prüfen ob : drin ist  
		dPauseAnfang = InputBox(vbcrlf & vbcrlf & "Pause Anfang", "Arbeitszeit", "0")  
		if dPauseAnfang = "" OR len(dPauseAnfang) < 3 then  
			dPauseAnfang = TimeValue("00:00")  
		else
			dPauseAnfang = GetTime(dPauseAnfang) ' prüfen ob : mit angegeben wurde  
			dPauseEnde = InputBox(vbcrlf & vbcrlf & "Pause Ende", "Arbeitszeit", "")  
			dPauseEnde = GetTime(dPauseEnde) ' prüfen ob : mit angegeben wurde  
		end if
		' **************** Rechne ****************  
		dPausenlaenge = CDate(dPauseEnde - dPauseAnfang)' Pausenlänge  
		szFinalMessage = "Mittagspause: " & vbTab & FormatDateTime(dPausenlaenge, 4) & "h" & vbcrlf  
		dAktuelleArbeitszeit = CDate((TimeValue(Now()) - dArbeitsBeginn) - dPausenlaenge)' Bis jetzt gearbeitet  
		szFinalMessage = szFinalMessage & "Arbeitszeit bisher: " & vbTab & FormatDateTime(dAktuelleArbeitszeit, 4) & "h" & vbcrlf  
		dSollerreicht = CDate(dArbeitsBeginn + dSollH + dPausenlaenge)' Wann ist Soll erreicht  
		szFinalMessage = szFinalMessage & "Soll erreicht: " & vbTab & FormatDateTime(dSollerreicht, 4) & "Uhr" & vbcrlf  
		if TimeValue(Now()) > dSollerreicht then' bis dahin sind es noch bzw. drüber   
			dZeitbisSoll = CDate(TimeValue(Now()) - dSollerreicht)    
			szFinalMessage = szFinalMessage & "schon drüber mit: " & vbTab & FormatDateTime(dZeitbisSoll, 4) & "h" & vbcrlf  
		else
			dZeitbisSoll = CDate(TimeValue(Now()) - dSollerreicht)
			szFinalMessage = szFinalMessage & "das dauert noch: " & vbTab & FormatDateTime(dZeitbisSoll, 4) & "h" & vbcrlf  
		end if
		If weekday(Date()) = vbFriday then' ist heute Freitag?  
			dSollerreicht = CDate(dArbeitsBeginn + dSollHFr + dPausenlaenge)
			szFinalMessage = szFinalMessage & vbcrlf & "heute Ende um: " & vbTab & FormatDateTime(dSollerreicht, 4) & "Uhr" & vbcrlf  
			dZeitbisSoll = CDate(TimeValue(Now()) - dSollerreicht)
			szFinalMessage = szFinalMessage & "das dauert noch: " & vbTab & FormatDateTime(dZeitbisSoll, 4) & "h" & vbcrlf  
		end if
		' **************** Finale Ausgabe ****************  
		'MsgBox szFinalMessage, cICON_INFO,"Arbeitszeit" ' Ausgabe  
		'PCListe = InputBox("Body", "Arbeitszeit" ,"TXT")  
		szUserChoice = MsgBox(szFinalMessage & vbcrlf & "Soll erreicht Zeit in Outlook eintragen?", cICON_INFO + cBUTTON_YESNO + cDEFBUTTON2,"Arbeitszeit")  
		' **************** Outlook Termin setzen ***************  
		if szUserChoice = cIDYES then
			Call Sub_OutlookTermin(dSollerreicht)
		end if
	end if
End Sub

'***************************************  
' Outlook Termin setzen  
'***************************************  
Sub Sub_OutlookTermin(szUhrzeit)
	Dim objOutlook, apptOutApp, objNamespace, objFolder, colItems, objItem, strFilter, colFilteredItems
	
	Set objOutlook = CreateObject("Outlook.Application")  
	Set objNamespace = objOutlook.GetNamespace("MAPI")  
	Set objFolder = objNamespace.GetDefaultFolder(9)
	' alten Termin suchen und löschen  
	Set colItems = objFolder.Items
	strFilter = "[Start] >= '" & date()-5 & "' AND [Start] <= '" & date()+1 & "'"   ' damit löscht er den Termin der letzten 5 Tage!   
	Set colFilteredItems = colItems.Restrict(strFilter)
	For Each objItem in colFilteredItems
		if instr(objItem.Subject,"done") AND instr(objItem.Body,"##$$§&&%%") then  
			objItem.Delete
		end if
	Next
	' neuen Termin heute erstellen  
	Set apptOutApp = objOutlook.CreateItem(1) 
	With apptOutApp 
		'.Start = date() & " " & Hour(Now()) & ":" & Minute(Now())  
		.Start = date() & " " & szUhrzeit  
		.Subject = "done"  
		.Body = "##$$§&&%%"  
		.Location = ""  
		.Duration = "0"  
		.ReminderMinutesBeforeStart = 0
		.ReminderPlaySound = False
		.ReminderSet = True
		.Sensitivity = 2
		.Save
	End With

	Set apptOutApp = Nothing
	Set objOutlook = Nothing
	Set objFolder = Nothing
	Set objNamespace = Nothing
	' http://msdn.microsoft.com/en-us/library/office/aa210899(v=office.11).aspx  
	' http://blogs.technet.com/b/heyscriptingguy/archive/2008/02/21/how-can-i-set-a-reminder-on-all-my-outlook-appointments.aspx?Redirected=true  
End Sub

'***************************************  
' Funktion   
'    fügt ein : in die Zeit ein  
'***************************************	  
Function GetTime(dZeit) ' prüfen ob : mit angegeben wurde  
	If InStr(dZeit, ":") = 0 Then dZeit = Left(dZeit, Len(dZeit) - 2) & ":" & Right(dZeit, 2)  
	GetTime = TimeValue(dZeit)
End Function