Migration von Benutzerdaten zur Umstellung von Windows XP zu Windows 7 2/2

Die Migration der Benutzerdaten nach einer Umstellung von Windows XP auf Windows 7 ist sehr zeitaufwendig, wie ich meinem vorherigen Blog-Post schon beschrieben habe.

Da man in der IT, Gott sei Dank, größtenteils automatisieren kann, habe ich mir diesen Umstand zur Nutze gemacht und passend zum Sicherungs-Skript, natürlich auch ein Wiederherstellungs-Skript gebaut.

Features:

• Außenstandorte werden unterstützt => wenn ein bestimmtes Default Gateway gesetzt ist, wird keine Wiederherstellung durchgeführt
• Konfigurierbares Home-Laufwerk
• Wiederherstellung nur, wenn Betriebssystem Windows7
• Wiederherstellung nur, wenn Computername ein bestimmtes Muster hat (z.B: INVW700001)
• Wiederherstellung von Ordnern
• Vorbereitung für Start/Stop von Prozessen
• Error-Handling
• Migration von OpenOffice zu LibreOffice
• Warten auf etwaige, laufende Softwarverteilung (Frontrange DSM: Niinst32.exe)
• Nach Wiederherstellung automatische Abmeldung 
• Flag bei erfolgte Wiederherstellung (in %APPDATA%)

Hier der Code:

'#####################################################

' Wiederherstellungsscript
'  Author: Oliver Skibbe oliskibbe (at) gmail.com
' Date: 2013-09-25

'#####################################################

' Constants
' Windows Version
Const Win2k = "5.0"
Const WinXP = "5.1"
Const Win2k3 = "5.2"
Const WinVista = "6.0"
Const Win7 = "6.1"
Const Win2k8 = "6.2"

' Stuff
Const Target = "INVW7"
Const HomeDrive = "Z:\"

' Objects
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objWMIService = GetObject("winmgmts:\\localhost\root\cimv2")

TargetVersion = Win7

' Get Windows Version
Set colOperatingSystem = objWMIService.ExecQuery("Select Version from Win32_OperatingSystem")
For Each objOperatingSystem in colOperatingSystem
 Version = objOperatingSystem.Version
Next

' Quit if target pc name is not XXX or uses other Version than Windows 7
strComputerName = WshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
If InStr(1, strComputerName, Target, VbTextCompare) = 0 Then
 WScript.Quit
Else
 ' If computer name is valid, check OS version
 If Not Mid(Version,1,3) = TargetVersion Then
  WScript.Quit
 End If 
End If ' end check valid target pc


' paths
strProfileDir = WshShell.ExpandEnvironmentStrings("%USERPROFILE%")
strProgramFilesDir = WshShell.ExpandEnvironmentStrings("%PROGRAMFILES%")
strAppDataDir = strProfileDir + "\AppData"
strLocalAppDataDir = strAppDataDir + "\Local"
strRoamingAppDataDir = strAppDataDir + "\Roaming"

' quit if restore already completed
RestoreFlag = strAppDataDir + "\Restore_done.flag"
If objFSO.FileExists(RestoreFlag) Then
 WScript.Quit
End If

' Get Default GW
Set colNetworkConfiguration = objWMIService.ExecQuery("Select DefaultIPGateway from  Win32_NetworkAdapterConfiguration Where IPEnabled = TRUE")
For Each objNetworkConfiguration in colNetworkConfiguration
 If Not IsNull(objNetworkConfiguration.DefaultIPGateway) Then 
  DefaultGateway = Join(objNetworkConfiguration.DefaultIPGateway, ",")
 End If
Next

' no restore in hannover so far
If DefaultGateway = "10.10.1.1" Then
 Wscript.Quit
End If

' sleep if dsm net install is currently running
ProcToWatch = "NIInst32.exe"
Set colProcesses = objWMIService.ExecQuery("Select * from Win32_Process Where Name ='" & ProcToWatch & "'")
Do Until colProcesses.Count = 0
 WScript.Sleep 10000
 Set colProcesses = objWMIService.ExecQuery("Select * from Win32_Process Where Name ='" & ProcToWatch & "'")
Loop

' Quit if home drive is not available / writable or wrong type
CheckDrive(HomeDrive)

WshShell.Popup "Die Rück-Sicherung der eigenen Dateien wurde gestartet", 3

' Source
SourceBase = HomeDrive + "\Sicherung"
If Not objFSO.FolderExists(SourceBase) Then
 MsgBox("Es wurde keine sicherung in " + SourceBase + " gefunden!")
 WScript.Quit
End If

' Targets
TargetDesktop = strProfileDir & "\Desktop"
TargetOwnFiles = strProfileDir + "\Documents"
TargetFavorites = strProfileDir & "\Favorites"
TargetLOfficeBase = strLocalAppDataDir  + "\LibreOffice\4\user"
TargetRoamingMSOffice = strRoamingAppDataDir + "\Microsoft"
TargetLocalMSOffice = strLocalAppDataDir + "\Microsoft"

' Restore Desktop
Restore SourceBase + "\Desktop", TargetDesktop, "Desktop", "dir", False
' Restore own files
Restore SourceBase + "\Eigene Dateien", TargetOwnFiles, "Eigene Dateien", "dir", False
' Restore Favorites
Restore SourceBase + "\Favoriten", TargetFavorites, "Favoriten", "dir", False
' Restore / Migrate OpenOffice to LibreOffice
Restore SourceBase + "\OpenOffice", TargetLOfficeBase, "LibreOffice", "dir", False
' Restore AppData Local MS Office
Restore SourceBase + "\Local\MSOffice", TargetLocalMSOffice, "MS Office", "dir", False
' Restore AppData Roaming MS Office
Restore SourceBase + "\Roaming\MSOffice", TargetRoamingMSOffice, "MS Office", "dir", False

' touch restore flag
objFSO.CreateTextFile(RestoreFlag)

WshShell.Popup "Die Rück-Sicherung der eigenen Dateien wurde beendet"
' log off
WScript.Sleep 5000
WshShell.run "shutdown /l /t 0"
' End of Main

''' Functions
' control processes
Function ProcessControl(proc, state, CheckState)

 If state = "stop" Then ' stop process
  cmd = "taskkill.exe /F /IM " + proc
 Else ' start process  
  cmd = proc
 End If ' end start / stop state
 
 ExitCode = WshShell.run (cmd, 1, true)
 If CheckState = True Then
  If ExitCode > 0 Then
   MsgBox "Fehler beim " + state + " von " + proc, vbCritical
   WScript.Quit
  End If ' end exit code
 End If ' end check state
End Function

Function Restore(Source, Target, Label, PathType, Required)
  ' try to copy folder
  If PathType = "dir" Then
  
   If objFSO.FolderExists(Source) Then
    If Not objFSO.FolderExists(Target) Then
     CreateFolderRecursive Target
    End If
    objFSO.CopyFolder Source, Target
   Else
    ' If required but does not exist: Quit!
    If Required = True Then
     MsgBox("Fehler bei der Rücksicherung von " + Label)
     WScript.Quit
    End If ' End Required Output
   End If ' end check source and target folder
  ' try to copy file 
  Elseif PathType = "file" Then
   ' try to copy file, source file name and target directory  
   If objFSO.FileExists(Source) And objFSO.FolderExists(Target) Then
    objFSO.CopyFile Source, Target
   Else
    ' If required but does not exist: Quit!
    If Required = True Then
     MsgBox("Fehler bei der Rücksicherung von " + Label)
     WScript.Quit
    End If ' End Required Output
   End If ' end check source and target file   
  ' not supported 
  Else  
   MsgBox("Typ wird nicht unterstützt, wählen Sie: dir, file")
   WScript.Quit
  End If
End Function

' Check target drive
Function CheckDrive(Drive)
  
 If objFSO.DriveExists(Drive) Then
  Set DriveState = objFSO.GetDrive(Drive)  
  ' Check home drive 
  If Not DriveState.IsReady = True Then
   ErrorText = "Laufwerk " + Drive + " ist nicht erreichbar, bitte starten Sie den PC neu!"
   ErrorOccured = True
  Else 
   ' 0: unkown, 1: Removable, 2: Fixed, 3: Network, 4: CD-Rom, 5: RAM-Disk
   If Not DriveState.DriveType = 1 And Not DriveState.DriveType = 2 And Not DriveState.DriveType = 3 Then 
    ErrorText = Drive + ": ist kein gültiger Laufwerkstyp, mögliche Typen: Netzwerk, Festplatte, Wechseldatenträger"
    ErrorOccured = True
   End If ' end check valid drive type
  End If
 Else
  ErrorText = "Laufwerk " + Drive + " existiert nicht, bitte starten Sie den PC neu!"
  ErrorOccured = True
 End If ' End Drive exists
 
 If ErrorOccured = True Then
  MsgBox(ErrorText)
  WScript.Quit
 End If
End Function

Function CreateFolderRecursive(FullPath)
 arr = split(FullPath, "\")
 path = ""
 For Each dir In arr
  If path <> "" Then 
   path = path & "\"
  End If
  path = path & dir
  If Not objFSO.FolderExists(path) Then 
   objFSO.CreateFolder(path)
  End If
 Next
End Function
' EOF

Das Skript sollte angepasst, getestet und im NETLOGON Verzeichnis abgelegt werden, anschließend kann es im Login-Skript verankert werden und stellt ab diesem Zeitpunkt automatisch bei der ersten Anmeldung die Daten wieder her.

Zum Download

Bei Fragen bitte melden!

Migration von Benutzerdaten zur Umstellung von Windows XP zu Windows 7 oder wie sichere ich automatisch für BenutzerInnen lokale Daten 1/2

In einem modernen Unternehmen werden häufig serverbasierte Profile und/oder Ordnerumleitungen für die persönlichen, PC-basierten, Daten der BenutzerInnen eingesetzt.

Dieses hat den Vorteil, dass auf den lokalen PCs keine Daten vorhanden sind und somit die Gefahr des Datenverlustes bei Ausfall, Diebstahl, Elementare Gefährdungen, etc. minimiert wird.

Wenn nun allerdings der Umstieg auf Windows 7 ansteht, wird einem bei Tests sehr schnell auffallen, dass die XP Profile nicht mit den W7 Profilen gemischt werden können und man somit, bei Anmeldung an Windows 7, nur ein temporäres Profil zugewiesen bekommt bzw. im schlimmsten Fall das XP Profil zerschiesst.
Dieses Problem tritt auf, da zu einem die Registry (betrifft serverbasierte Profile) andere Einträge aufweist, sowie die Verzeichnisstruktur (z.B. Ordnerumleitungen) seit Windows Vista eine andere ist.

Kurzer Exkurs zu den beiden Möglichkeiten:

Serverbasierte Profile

Das serverbasierte Profil beinhaltet das gesamte Profil eines Benutzer-Accounts, inkl. Registry und %USERPROFILE% (genauere Informationen dazu gibt es bei Microsoft und zwar hier). Die Daten werden auf den lokalen PC geschrieben und gelesen, d.h. es findet eine Synchronisation zwischen PC und Server statt.

Vorteil(e):

• Alle Daten sind vollständig auf dem Server => Vermeidung von Datenverlusten
• Alle Daten sind vollständig auf dem Client => Offline Arbeit möglich

Nachteil(e):

• Verzögerung beim Anmelden, da das gesamte Profil vom Server heruntergeladen, also synchronisiert wird, je nach Bandbreite und Auslastung des Servers kann dieses zu unangenehmen Verzögerungen und eingeschränktem Produktionsausfall führen. Beispiel: die Anmeldung dauert 5 Minuten mit einem serverbasierten Profil und 1 Minute mit lokalem Profil, in einem Arbeitsjahr würde sich das Ganze zu 14,7 Stunden summieren und somit pro BenutzerIn zu fast 2 Tagen Produkionsausfall per anno führen würde
• Synchronisation der Daten erst bei Abmeldung, bei Ausfall des PCs sind die letzten Änderungen nicht gesichert, Abmeldung wird ebenfalls verzögert
• Höhere Grundlast auf den Servern/Storage und Netzwerk zu Stoßzeiten (Beginn, Mittagspause, Feierabend)

Ordnerumleitungen

Ordnerumleitungen können über Gruppenrichtlinien konfiguriert werden und bieten eine einfache Möglichkeit zur Umleitung von Ordnern auf andere Systeme, gerne für Ordner wie Eigene Dateien oder Desktop genutzt, damit die Anmeldezeit verringert, aber die Gefährdung durch Datenverlust dennoch minimiert.

Vorteil(e):

• Konfigurierte sind vollständig auf dem Server => Vermeidung von Datenverlusten
• Keine Verzögerung beim An- und Abmelden

 Nachteil(e):

• Höhere Grundlast auf den Servern/Storage und Netzwerk, da Live gearbeitet wird
• Keine Offline-Arbeit möglich

Da beide Lösungen jeweils Vor- und Nachteile bieten, sollte genau geprüft werden, welche von beiden genutzt oder wie beide kombiniert werden sollten.
Typisch wird das serverbasierte Profil in Kombination mit Ordnerumleitung von Desktop und Eigene Dateien genutzt, so hat man eine effiziente Lösung mit geringem Impact auf die Datensicherheit und Gesamt Performance


Zurück zum Thema, bei der Umstellung von Windows XP auf Windows 7 gibt es natürlich nicht nur die Profile/persönlichen Daten zu beachten, sondern es gilt auch Dinge zu prüfen, wie z.B.:

• Der wichtigste Punkt: Software-Kompabilität zu Windows 7, inkl. Architektur (Test durch IT, Fachabteilung)
• Upgrade der Domänen-Controller (Achtung, abhängige Authentifizierungsdienste bedenken, z.B. SSPI, NTLMv1) zur Nutzung der neuen GPO Features
• Schulung, Schulung und Schulung => erhöht Akzeptanz der Mitarbeiter, selten gilt: Neu ist immer besser ;-)
• Planung, Planung und Planung: Test, Logistik (Wie, wo, wann und durch wen wird installiert), Rollout (Etagenweise, Abteilungsweise, ...), Transparenz (Was funktioniert wie, Wann passiert was) => Akzeptanz der Mitarbeiter

In meinem Anwendungsfall kommen keine serverbasierten Profile zum Einsatz, das hat zur Folge, das Daten wie z.B. Favoriten, Wörterbücher, Signaturen (falls nicht automatisiert, siehe dazu meine vorherigen Einträge), Dokumente nur lokal auf den PCs abgelegt werden.
Es gibt nun zwei Wege um dieses "Dilema" zu lösen.
Der eine Weg ist eine organisatorische Lösung, d.h. die BenutzerInnen werden informiert, dass ab sofort alle Daten auf dem Home Laufwerk gespeichert bzw. dort hin verschoben werden sollen, der andere Weg ist eine technische Lösung in Form eines Skripts, dass diese Aufgabe selbstständig erledigt.
Um die größtmögliche Akzeptanz mit Effizienz zu kombinieren, habe ich mich für einen gemischten Weg entschieden, d.h. es gibt eine Dienstanweisung, die sagt, dass alles Zukünftige nur noch auf dem Home-Laufwerk gespeichert werden soll (+ Ordnerumleitungen), sowie zwei Skripte zur Sicherung und Wiederherstellung wurden von mir geschrieben.

Da natürlich, aus Gründen des Datenschutz, kein Zugriff auf die Home-Laufwerke der BenutzerInnen besteht, kommt keine serverbasierte Sicherung der Daten in Frage, sondern eine Lösung, die durch den Benutzer entweder manuell oder automatisch gestartet wird.

Entschieden habe ich mich für die automatische Lösung mit Hilfe des Login-Skripts, somit wird bei Login eine Sicherung der konfigurierten Pfade durchgeführt, Nachteil: die Sicherung kann unvollständig sein. Ich habe mich bewusst für das Login-Skript entschieden, da BenutzerInnen beim Herunterfahren des PCs häufig den Bildschirm als Erstes ausschalten und somit Bildschirmmeldungen nicht mehr sehen können (natürlich wäre auch eine automatisierte E-Mail aus dem Skript heraus möglich, allerdings werden diese auch gern ignoriert..)

Folgende Features unterstützt das Sicherungs-Skript (durch Anpassung der Pfade und der Version kann das Skript auch als normales Sicherungsskript bei PC-Wechsel genutzt werden!):

• Außenstandorte werden unterstützt => wenn ein bestimmtes Default Gateway gesetzt ist, wird keine Sicherung durchgeführt
• Konfigurierbares Home-Laufwerk
• Sicherung nur, wenn Betriebssystem Windows XP
• Sicherung nur, wenn Computername ein bestimmtes Muster hat (z.B: PCXP00001)
• Meldung bei Überschreitung der konfigurierbaren Größe
• Rekursive Sicherung von Ordner, bei Ausschluss von Dateien größer als X (z.B. Outlook Ordner ohne pst-file)
• Meldung, wenn Dateien in einem Ordner gefunden werden, die zu Tag X (Datum/Meldung konfigurierbar, abhängig vom Default Gateway) erledigt sein müssen
• Start/Stop von Prozessen
• Error-Handling
• Default Sicherungspfade: Desktop (250 MB), Eigene Dateien (250 MB), Outlook (pst file bis 100 MB), MS Office, OpenOffice (Textbausteine, Wörterbücher)

Hier der Code

'#####################################################

' Sicherungsscript
'  Author: Oliver Skibbe oliskibbe (at) gmail.com
' Date: 2013-09-17

'#####################################################

' Constants
' Windows Version
Const Win2k = "5.0"
Const WinXP = "5.1"
Const Win2k3 = "5.2"
Const WinVista = "6.0"
Const Win7 = "6.1"
Const Win2k8 = "6.1"

' Stuff
Const Target = "INV"
Const HomeDrive = "Z:\"

' max transferred bytes
' 100 MB
Const maxDefaultSize = 104857600
' 250 MB
Const maxDesktopSize = 262144000
Const maxOwnFilesSize = 262144000

TargetVersion = WinXP

' Objects
Set WshShell = WScript.CreateObject("WScript.Shell")
Set objFSO = CreateObject("Scripting.FileSystemObject") 
Set objWMIService = GetObject("winmgmts:\\localhost\root\cimv2")

' Get Windows Version
Set colOperatingSystem = objWMIService.ExecQuery("Select Version from Win32_OperatingSystem")
For Each objOperatingSystem In colOperatingSystem
 Version = objOperatingSystem.Version
Next

' Get Default GW
Set colNetworkConfiguration = objWMIService.ExecQuery("Select DefaultIPGateway from  Win32_NetworkAdapterConfiguration Where IPEnabled = TRUE")
For Each objNetworkConfiguration in colNetworkConfiguration
 If Not IsNull(objNetworkConfiguration.DefaultIPGateway) Then 
  DefaultGateway = Join(objNetworkConfiguration.DefaultIPGateway, ",")
 End If
Next

' Quit if target pc name is not XXX or uses other Version than Windows 7
strComputerName = WshShell.ExpandEnvironmentStrings("%COMPUTERNAME%")
If InStr(1, strComputerName, Target, VbTextCompare) = 0 Then
 WScript.Quit
Else
 ' If computer name is valid, check OS version
 If Not Mid(Version,1,3) = TargetVersion Then
  WScript.Quit
 End If 
End If ' end check valid target pc

' quit if hannover gw ip => no backup
If DefaultGateway = "10.10.1.1" Then
 Wscript.Quit
End If

' quit if Foobar town gw ip => no backup
If DefaultGateway = "10.16.1.1" Then
 Wscript.Quit
End If

' Quit if home drive is not available / writable or wrong type
CheckDrive(HomeDrive)

' Helper vars
strProgramFiles = WshShell.ExpandEnvironmentStrings("%PROGRAMFILES%")
strProfileDir = WshShell.ExpandEnvironmentStrings("%USERPROFILE%")
strAppDataDir = WshShell.ExpandEnvironmentStrings("%APPDATA%")
strLocalDir = strProfileDir + "\Lokale Einstellungen\Anwendungsdaten"

' Source dirs
SourceDesktop = strProfileDir & "\Desktop"
SourceFavorites = strProfileDir & "\Favoriten"
SourceOwnFiles = strProfileDir + "\Eigene Dateien"
SourceOOfficeBase = strAppDataDir  + "\OpenOffice.org\3\user"
SourceRoamingMSOfficeBase = strAppDataDir  + "\Microsoft"
SourceLocalMSOfficeBase = strLocalDir  + "\Microsoft"

' Target dirs
TargetBase = HomeDrive + "\Sicherung"
TargetDesktop = TargetBase + "\Desktop"
TargetOwnFiles = TargetBase + "\Eigene Dateien"
TargetFavorites = TargetBase + "\Favoriten"
TargetOOffice = TargetBase + "\OpenOffice"
TargetRoamingMSOffice = TargetBase + "\Roaming\MSOffice"
TargetLocalMSOffice = TargetBase + "\Local\MSOffice"

' create backup folder if not exists
If Not objFSO.FolderExists(TargetBase) Then
 objFSO.CreateFolder TargetBase
End If ' End check folder

WshShell.Popup "Die Sicherung der eigenen Dateien wurde gestartet", 2

'''' Desktop ''''
 BackupFolder SourceDesktop, TargetDesktop, "Desktop", maxDesktopSize, False

'''' Own files ''''
 BackupFolder SourceOwnFiles, TargetOwnFiles, "Eigene Dateien", maxOwnFilesSize, False

'''' Favorites ''''
 BackupFolder SourceFavorites, TargetFavorites, "Favoriten", maxDefaultSize, False

'''' OpenOffice ''''
 BackupFolder SourceOOfficeBase + "\autotext", TargetOOffice + "\autotext", "OOffice Textbausteine", maxDefaultSize, False
 BackupFolder SourceOOfficeBase + "\wordbook", TargetOOffice + "\wordbook", "OOffice Wörterbuch", maxDefaultSize, False
 
'''' Microsoft Office ''''
 BackupFolder SourceRoamingMSOfficeBase + "\Templates", TargetRoamingMSOffice + "\Templates", "MS Office Templates", maxDefaultSize, False
 BackupFolder SourceRoamingMSOfficeBase + "\Signatures", TargetRoamingMSOffice + "\Signatures", "MS Office Signatures", maxDefaultSize, False
 BackupFolder SourceRoamingMSOfficeBase + "\Document Building Blocks", TargetRoamingMSOffice + "\Document Building Blocks", "MS Office Textbausteine", maxDefaultSize, False

'''' Outlook folder without pst (via file size) ''''
 BackupFolderRecursiveExcludeMaxSize SourceRoamingMSOfficeBase + "\Outlook", TargetRoamingMSOffice + "\Outlook", "Outlook", maxDefaultSize, False
 BackupFolderRecursiveExcludeMaxSize SourceLocalMSOfficeBase + "\Outlook", TargetLocalMSOffice + "\Outlook", "Outlook", maxDefaultSize, False

'''' Auftragsdaten ''''
' Message if files are available (could be just in addition to a due time)
CheckFileCountInFolder "C:\Auftragsdaten\Daten", "Auftragsdaten", 1



' Target Size Output
Set objFolder = objFSO.GetFolder(TargetBase) 
' returns byte
TargetSize =  objFolder.Size

WshShell.Popup "Die Sicherung der eigenen Dateien wurde beendet. Es wurden " + ConvertSize(TargetSize) + " auf Ihr Laufwerk " + HomeDrive + " übertragen", 3
' End of Main

''' Functions
' control processes
Function ProcessControl(proc, state, CheckState)

 If state = "stop" Then ' stop process
  cmd = "taskkill.exe /F /IM " + proc
 Else ' start process  
  cmd = proc
 End If ' end start / stop state
 
 ExitCode = WshShell.run (cmd, 1, true)
 If CheckState = True Then
  If ExitCode > 0 Then
   MsgBox "Fehler beim " + state + " von " + proc, vbCritical
   WScript.Quit
  End If ' end exit code
 End If ' end check state
End Function

' Pretty output for bytes
Function ConvertSize(Size)
 Do While InStr(Size,",")
  CommaLocate = InStr(Size,",")
  Size = Mid(Size,1,CommaLocate - 1) & _
    Mid(Size,CommaLocate + 1,Len(Size) - CommaLocate)
 Loop

 Suffix = " B"
 If Size >= 1024 Then suffix = " KB"
 If Size >= 1048576 Then suffix = " MB"
 If Size >= 1073741824 Then suffix = " GB"
 If Size >= 1099511627776 Then suffix = " TB"

 Select Case Suffix
  Case " KB" Size = Round(Size / 1024, 1)
  Case " MB" Size = Round(Size / 1048576, 1)
  Case " GB" Size = Round(Size / 1073741824, 1)
  Case " TB" Size = Round(Size / 1099511627776, 1)
 End Select

 ConvertSize = Size & Suffix
End Function

' return due dates e.g. till something will be done, see CheckFileCountInFolder
Function RolloutDate(DefaultGateway)
 ' Default
 Rollout = "Offen"
 
 Set objRolloutDates = CreateObject("Scripting.Dictionary")
 ' Foobar town
 objRolloutDates.Add "10.16", "05.09"
 ' Hannover
 objRolloutDates.Add "10.10", "Offen"

 For Each RolloutDate In objRolloutDates
  If InStr(1, DefaultGateway, RolloutDate, VbTextCompare) > 0 Then
   RolloutDate = objRolloutDates(RolloutDate)
   Exit Function
  End If
 Next
End Function

' Copy Folder
Function BackupFolder(Source, Target, Label, maxSize, Required) 
 ' check if source exists
 If objFSO.FolderExists(Source) Then
  ' create target folder
  If Not objFSO.FolderExists(Target) Then
   CreateFolderRecursive Target
  End If ' End check folder
  
  Set objFolder = objFSO.GetFolder(Source) 
  ' returns byte
  FolderSize =  objFolder.Size
  ' copy if folder size is less than ~XXX Megabyte..
  If FolderSize < maxSize Then
   objFSO.CopyFolder Source, Target
  Else
   MsgBox(Label + " ist zu groß: " + ConvertSize(FolderSize) + ". Bitte löschen Sie unnötige Dateien oder verschieben Sie diese auf Ihr Laufwerk H:\. Falls diese Schritte nicht helfen, wenden Sie sich bitte an die Hotline")
  End If ' end of size
 Else
  If Required = True Then
   MsgBox(Label + " (" + Source + ") wurde nicht gefunden, muss aber vorhanden sein!")
   WScript.Quit
  End If
 End If
End Function

' Copy File
Function BackupFile(Source, Filename, Target, Label, maxSize, Required) 

 FullPath = Source + "\" + Filename
 
 ' check if source exists
 If objFSO.FileExists(FullPath) Then
  ' create target folder
  If Not objFSO.FolderExists(Target) Then
   CreateFolderRecursive Target
  End If ' End check folder
  
  Set objFile = objFSO.GetFile(FullPath) 
  ' returns byte
  FileSize =  objFile.Size
  ' copy if folder size is less than ~XXX Megabyte..
  If FileSize < maxSize Then
   objFSO.CopyFile FullPath, Target + "\" + Filename
  Else
   MsgBox(Label + " ist zu groß: " + ConvertSize(FileSize) + ". Bitte löschen Sie diese Datei oder verschieben Sie diese auf Ihr Laufwerk H:\. Falls diese Schritte nicht helfen, wenden Sie sich bitte an die Hotline")
  End If ' end of size
 Else
  If Required = True Then
   MsgBox(Label + " (" + Source + ") wurde nicht gefunden, muss aber vorhanden sein!")
   WScript.Quit
  End If
 End If
 
End Function

' check if x file(s) exist in given path
Function CheckFileCountInFolder(Path, Label, maxFiles)

 FileCount = 0
 
 If objFSO.FolderExists(Path) Then
  Set objFolder = objFSO.GetFolder(Path)
  Set colFiles = objFolder.Files
  For Each objFile In colFiles
   FileCount = FileCount + 1  
  Next
  If maxFiles > 0 And FileCount >= maxFiles Then
   MsgBox( Cstr(FileCount) + " Datei(en) in " + Label + " vorhanden, bitte bis zum " + Chr(34) + RolloutDate(DefaultGateway) + Chr(34) + " abarbeiten / entfernen oder bei der IT-Hotline melden!")
  End If 
 End If ' end FileExists 
End Function

' Copy Folder
Function BackupFolderRecursiveExcludeMaxSize(Source, Target, Label, maxSize, Required) 
 ' check if source exists
 If objFSO.FolderExists(Source) Then
  ' create target folder
  If Not objFSO.FolderExists(Target) Then
   CreateFolderRecursive Target
  End If ' End check folder
  
  Set objFolder = objFSO.GetFolder(Source) 
  Set Files = objFolder.Files
  For Each File in Files
   If Not InStr(1, File.Name, "outlook.ost", VbTextCompare) > 0 Then
    If File.Size < maxSize Then
     File.Copy(Target + "\" + File.Name)
    Else
     MsgBox(Label + " ist zu groß: " + ConvertSize(File.Size) + ". Bitte löschen Sie diese Datei oder verschieben Sie diese auf Ihr Laufwerk H:\. Falls diese Schritte nicht helfen, wenden Sie sich bitte an die Hotline")
    End If
   End If
  Next 
 Else
  If Required = True Then
   MsgBox(Label + " (" + Source + ") wurde nicht gefunden, muss aber vorhanden sein!")
   WScript.Quit
  End If
 End If
 
End Function

' Check target drive
Function CheckDrive(Drive)
  
 If objFSO.DriveExists(Drive) Then
  Set DriveState = objFSO.GetDrive(Drive)  
  ' Check home drive 
  If Not DriveState.IsReady = True Then
   ErrorText = "Laufwerk " + Drive + " ist nicht erreichbar, bitte starten Sie den PC neu!"
   ErrorOccured = True
  Else 
   ' 0: unkown, 1: Removable, 2: Fixed, 3: Network, 4: CD-Rom, 5: RAM-Disk
   If Not DriveState.DriveType = 1 And Not DriveState.DriveType = 2 And Not DriveState.DriveType = 3 Then 
    ErrorText = Drive + ": ist kein gültiger Laufwerkstyp, mögliche Typen: Netzwerk, Festplatte, Wechseldatenträger"
    ErrorOccured = True
   End If ' end check valid drive type
  End If
 Else
   ErrorText = "Laufwerk " + Drive + " existiert nicht, bitte starten Sie den PC neu!"
   ErrorOccured = True
 End If ' End Drive exists
 
 If ErrorOccured = True Then
  MsgBox(ErrorText)
  WScript.Quit
 End If
End Function

Function CreateFolderRecursive(FullPath)
 Set oFs = WScript.CreateObject("Scripting.FileSystemObject")
 arr = split(FullPath, "\")
 path = ""
 For Each dir In arr
  If path <> "" Then path = path & "\"
  path = path & dir
  If oFs.FolderExists(path) = False Then oFs.CreateFolder(path)
 Next
End Function

' EOF

Das Skript sollte angepasst, getestet und im NETLOGON Verzeichnis abgelegt werden, anschließend kann es im Login-Skript verankert werden und sichert ab diesem Zeitpunkt automatisch bei jeder Anmeldung die Daten.

Zum Download

Bei Fragen bitte melden!

Outlook Signaturen und wie bekämpft man die Anarchie 2/2

Wie bereits im letzten Blogpost als mögliches, bzw. typisches Problem erwähnt, müssen für eine saubere Signatur vollständige Daten im AD enthalten sein.

Dazu kann man entweder auf die Mitarbeiter vertrauen, dass diese sich immer melden, wenn sich etwas ändert oder man beschäft je nach Unternehmensgröße einfach eine Vollzeitstelle damit, welche den ganzen Tag durchs Haus läuft und alle Mitarbeiter "inventarisiert"...natürlich nur ein Spaß.. ;-)

Die, meiner Meinung nach, sinnvollste Lösung ist die kontrollierte Selbstpflege durch die BenutzerInnen selbst, dazu stellt man ihnen ein Tool bereit welches die Daten abfragt und speichert.

Vorteile:

• weniger Hotlineanrufe
• BenutzerInnen möchten die Daten selbst ändern, damit z.B. ihre Signatur aktuell ist

Ich habe mich dabei für eine PHP Web-Applikation entschieden, da diese unabhängig vom Computer und vom Server ist, da es PHP für ebenso für Windows gibt.

Im Anwendungsfall habe ich mich für einen netten, kleinen Ubuntu 12.04 LTS Server mit LAP Stack (ja, der heißt normalerweise LAMP, allerdings benötige ich keinen MySQL-Server.. ;-)) entschieden, da ich eine gewissen Open-Source Affinität habe, Lizenzkosten sparen möchte und sehr gute Erfahrung damit gemacht habe.
Dieser authentifiziert die Benutzer mittels Kerberos über den Apache2 am AD (voraussichtlich folgt dazu ein kleines Tutorial im nächsten Post), anschließend übernimmt PHP den Benutzernamen über die Server Variable REMOTE_USER.

Da die Code-Menge dem Leserahmen sprengen würde, gibt es dieses Mal nur einen Direkt-Download als Zip-Archiv: https://dl.dropboxusercontent.com/u/9482545/webapp_signatur.zip

Das Zip-Archiv muss auf das Zielsystem in einen, für den Webserver lesbaren Pfad gepackt werden (je nach Distribution: /var/www, /srv/htdocs, ...).

Features:

• 1-N Standorte können konfiguriert / vorbereitet werden
• Schreiben auf den jeweilig konfigurierten, lokalen DC (bei mehreren Standorten, damit nach Neuanmeldung das Signatur Generierungsskript die aktuellen Daten bekommt)
• Generierung der Adressdaten über die Auswahl des Standorts, auch bei mehreren Standorten pro Stadt
• Generierung der Fax-/Telefonnummer über die Auswahl des Standorts, es wird nur die Durchwahl eingegeben => einheitliche Formatierung
• Handynummer wird über Auswahl der Vorwahl+Rufnummer generiert => einheitliche Formatierung
• Unterstützung für Unterfirmen, abhängig vom Standort (z.B. Wayne Enterprises Hannover, Wayne Business Berlin) => unterschiedliche Einträge in die Firmenfelder
• Unterstützung von Geschäftsbereichen/Abteilungen und Job-Titeln
  

Folgende Schritte müssen erfüllt werden, damit das ganze lauffähig wird:

• Geringe PHP Kenntnisse
• Fortgeschrittene Linux Kenntnisse (für Kerberos Authentifizierung )
• Installation Apache2 mit PHP (+ LDAP Module) und Authentifizierung (Zugriff auf REMOTE_USER) z.B. Kerberos oder mod_sspi (nur für Win32 und Apache2 2.0/2.2)
• Anpassung der Konfiguration in config.inc.php nach eigenem Ermeßen.
• Anpassung der index.php für CI-Anpassungen

Einen Schönheitsfehler gibt es allerdings noch, die Übertragung wird per Ajax durchgeführt und der Return vom Speichern zurück zur Index.php funktioniert noch nicht perfekt.

Da die Daten im AD nun im Laufe der Zeit aktualisiert werden, kann man aus diesen z.B. genauso leicht eine Telefonliste genieren.


Bei Fragen bitte wie immer einfach melden. ;-)

Outlook Signaturen und wie bekämpft man die Anarchie 1/2

Da es häufiger vorkommt, dass in einem großen Unternehmen BenutzerInnen innerhalb des Unternehmens oder der Standorte umziehen, ändern sich dementsprechend die Benutzerdaten und die Signatur, zu dem sieht jede Signatur irgendwie anders aus.


Mögliche Probleme:

• Anarchie bei der Signaturerstellung (z.B. Telefonnummernformat, Grußformel, usw.), Corporate Identity soll erreicht werden
• Aktualität der Daten, siehe dazu meinen nächsten Blogpost => Wie halte ich die AD-Daten aktuell, bzw. lasse es die machen, die wissen sollten wo sie sitzen -> die BenutzerInnen

Damit man diese Signatur nicht bei jeder Person manuell erstellen muss, gibt es verschiedene Möglichkeiten diese zu verteilen.

Folgende Fakten haben wir:

• Outlook Signatur liegt im Standard in %APPDATA% => C:\Users\%username%\AppData\Roaming\Microsoft\Signatures)
• Active-Directoy mit aktuellen Daten (dazu komme ich im nächsten Blogpost ;-)) => Größtes Problem
• Signatur soll weiterhin anpassbar sein oder auch nicht => großer, technischer Unterschied!

Folgende Verteilungsmöglichkeiten sind mir dabei in den Sinn gekommen:

1. Verteilung einer fertigen Signatur

Signatur wird per Skript auf dem NETLOGON Laufwerk erzeugt und per Login-Skript verteilt.
Die Zuweisung würde über die Registry erfolgen:

•  Zuweisung über den "offiziellen" Weg (KB: 2691977), HKEY_CURRENT_USER\Software\Microsoft\Office\x.0\Common\MailSettings Nachteil: BenutzerInnen können ihre Signatur nicht mehr in Outlook anpassen.
•  Zuweisung über den inoffiziellen Weg, direkt in das Profil des Benutzers: HKEY_CURRENT_USER\Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\Outlook\9375CFF0413111d3B88A00104B2A6676\00000001 ("1" bedeutet Kontonummer, im Unternehmen normalerweise die 1) Vorteil: Benuter können Ihre Signaturen selber setzen, Nachteil: Signaturnamen liegen als Binary Type im Hex Format vor ("00 4D" => "M") und somit etwas komplizierter zu implementieren

Vorteile:klar definierte Signatur, Zuweisung über Login-Skript einfach möglich, da Domänen-Benutzer in HKCU schreiben dürfen
Nachteil: statisch, da aktualisierte Signatur erst verfügbar, wenn der nächste Genierungslauf durch ist

2. Generierung der Signatur über ein VBSkript im Login-Skript.

Die Zuweisung würde hierbei entweder über die Registry Keys oder über die VB Funktionen erfolgen.
Vorteile: lesbarer Code ohne Registry Zugriffe, Generierung der Signatur bei Login
Nachteile: weiteres Skript muss über das Login-Skript aufgerufen werden


Für meinen Anwendungsfall habe ich mich für die zweite Variante entschieden, da diese deutlich einfacher zu warten ist.

Dazu hier der Code für die Signatur-Generierung (Download via Dropbox: https://dl.dropboxusercontent.com/u/9482545/Outlook_signatur.vbs) :

' Objects
Set objSysInfo = CreateObject("ADSystemInfo")
Set WshShell = CreateObject("WScript.Shell")
Set objUser = GetObject("LDAP://" & objSysInfo.UserName)
Set objWord = CreateObject("Word.Application")

' Signature stuff
strName = objUser.givenName + " " + objUser.sn
strDepart = objUser.Department
strDesc = objUser.Description
strStreet = objUser.StreetAddress
strLocation = objUser.l
strPostCode = objUser.PostalCode
strPhone = objUser.TelephoneNumber
strMobile = objUser.Mobile
strFax = objUser.FacsimileTelephoneNumber
strEmail = objUser.mail
strCompany = objUser.Company
aQuote = Chr(34)
aNewLine = Chr(11)

If strCompany = "Dummyhausen" then
 strCompanyTitle = "Foobar company Dummyhausen"
 strCompanyWeb = "http://www.specialpage.de"
Else 
 strCompanyTitle = "Foobar company"
 strCompanyWeb = "http://www.foobar.de"
End If

Set objDoc = objWord.Documents.Add()
Set objSelection = objWord.Selection
Set objEmailOptions = objWord.EmailOptions
Set objSignatureObject = objEmailOptions.EmailSignature
Set objSignatureEntries = objSignatureObject.EmailSignatureEntries

objSelection.Font.Name = "Arial"
objSelection.Font.Size = 10
objSelection.TypeText "Mit freundlichem Gruß"
objSelection.TypeText vbCrLf
if (strCred) Then objSelection.TypeText strCred & strName Else objSelection.TypeText strName
objSelection.TypeText vbCrLf & vbCrLf
' Bold
objSelection.Font.Bold = True
objSelection.TypeText strCompanyTitle + aNewLine
objSelection.TypeText strDepart
objSelection.Font.Bold = False
' not bold
objSelection.TypeText vbCrLf & vbCrLf
if (strCred) Then objSelection.TypeText strCred & strName Else objSelection.TypeText strName
objSelection.TypeText aNewLine
objSelection.TypeText strDesc
objSelection.TypeText vbCrLf
objSelection.TypeText strStreet & aNewLine
objSelection.TypeText strPostCode & " " & strLocation & aNewLine
objSelection.TypeText "Tel: " & strPhone & aNewLine
if (strFax) Then objSelection.TypeText "Fax: " & strFax  & aNewLine
if (strMobile) Then objSelection.TypeText "Mobil: " & strMobile  & aNewLine
objSelection.TypeText vbCrLf
objDoc.Hyperlinks.Add objSelection.Range, "Mailto:" & strEmail, , , strEmail
objSelection.TypeText " | "
objDoc.Hyperlinks.Add objSelection.Range, strCompanyWeb, , ,strCompanyWeb
objSelection.TypeText vbCrLf
objSelection.TypeText "________________________________"
objSelection.TypeText vbCrLf & vbCrLf
objSelection.TypeText "Diese E-Mail enthält vertrauliche und/oder rechtlich geschützte Informationen. Wenn Sie nicht der richtige Adressat sind oder diese E-Mail irrtümlich erhalten haben, informieren Sie bitte sofort den Absender und vernichten Sie diese Mail. Das unerlaubte Kopieren sowie die unbefugte Weitergabe dieser Mail ist nicht gestattet."
objSelection.TypeText vbCrLf & vbCrLf
objSelection.TypeText "This e-mail may contain confidential and/or privileged information. If you are not the intended recipient (or have received this e-mail in error) please notify the sender immediately and destroy this e-mail. Any unauthorised copying, disclosure or distribution of the material in this e-mail is strictly forbidden."
objSelection.TypeText vbCrLf

Set objSelection = objDoc.Range()

' full signature
objSignatureEntries.Add "Full Signature", objSelection
objSignatureObject.NewMessageSignature = "Full Signature"

objDoc.Saved = True

' reply signature
objSignatureEntries.Add "Reply Signature", objSelection
objSignatureObject.ReplyMessageSignature = "Reply Signature"
objDoc.Saved = True
' EOF

Dieses Skript hat keinerlei Ausgaben, sondern verrichtet die Arbeit komplett im Hintergrund, somit werden die BenutzerInnen nicht belästigt, im Beispiel wird die gleiche Signatur für die "Antwort Signatur" genommen, das könnte man noch aufteilen, in dem man eine Kurzsignatur dazu entwirft, mit dem Beispiel sollte man das eigentlich einfach hinbekommen.

Es nutzt die Office VBSkript Bibliotheken und liest die eigenen Benutzerdaten aus dem AD.


Nun muss das Skript nur noch in das Login-Skript eingebaut werden, anschließend werden bei allen PC-Anmeldungen die Signaturen neugeschrieben und aktiviert.


Fazit: Ohne großen Aufwand kann die Corporate Identity durchgesetzt werden.

Download-Link: https://dl.dropboxusercontent.com/u/9482545/Outlook_signatur.vbs


Bei Fragen bitte einfach melden!


Im zweiten Teil wird es um die vereinfachte Aktualisierung der AD BenutzerInnen Daten gehen.

Sekretariate und Chefs die eigene Kalendereinträge erstellen/verändern

Microsoft Outlook bietet nützliche Funktionen um eine Vertretung oder ein Sekretariat zu unterstützen.

Eine wichtige Funktion gibt es allerdings nicht, nämlich eine Information, wenn der Eigentümer eines Kalenders selber Einträge hinzufügt, ändert oder löscht.
Diese Informationen gehen komplett am Sekretariat vorbei und müssten manuell kommuniziert werden, da wir aber die Welt kennen, geht sowas natürlich häufig unter und das Terminchaos ist vorprogrammiert...

Damit das nicht passiert, habe ich eine Outlook VBA Erweiterung geschrieben, welche diese Funktionen nachrüstet.

Achtung, da ich eig. kein VBA-Entwickler bin, kann der Code wahrscheinlich noch besser sein, aber für den Anwendungsfall reicht es wohl..

Unterstützte Funktionen:

• Hinzufügen eines Eintrags
• Ändern eines Eintrags
• Löschen eines Eintrags
• Separate Anzeige für Ganztägige Termine
• Übersetzbar
• Automatisches Ausblenden des Betreff,Inhalt und Ort bei "Privat" Markierung

Beispiel:

E-Mail Subject: Hinzugefügt: Kalendereintrag "Ein neuer Termin" von Skibbe, Oliver

E-Mail Inhalt:
Hinzugefügt: Kalendereintrag "Ein neuer Termin" von Skibbe, Oliver
Start: 10:30 am Mittwoch, 10. Juli 2013
Ende: 13:00 am Mittwoch, 10. Juli 2013
Status: Beschäftigt
Ort: Hannover
Inhalt: Besprechung mit XY zum Thema Z

Und hier der Code:

Option Explicit

'   This program is free software: you can redistribute it and/or modify
'   it under the terms of the GNU General Public License as published by
'   the Free Software Foundation, either version 3 of the License, or
'   (at your option) any later version.
'
'   This program is distributed in the hope that it will be useful,
'   but WITHOUT ANY WARRANTY; without even the implied warranty of
'   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
'   GNU General Public License for more details.
'
'   You should have received a copy of the GNU General Public License
'   along with this program.  If not, see <http://www.gnu.org/licenses/.
'
'   Dieses Programm ist Freie Software: Sie können es unter den Bedingungen
'   der GNU General Public License, wie von der Free Software Foundation,
'   Version 3 der Lizenz oder (nach Ihrer Option) jeder späteren
'   veröffentlichten Version, weiterverbreiten und/oder modifizieren.
'
'   Dieses Programm wird in der Hoffnung, dass es nützlich sein wird, aber
'   OHNE JEDE GEWÄHRLEISTUNG, bereitgestellt; sogar ohne die implizite
'   Gewährleistung der MARKTFÄHIGKEIT oder EIGNUNG FÜR EINEN BESTIMMTEN ZWECK.
'   Siehe die GNU General Public License für weitere Details.
'
'   Sie sollten eine Kopie der GNU General Public License zusammen mit diesem
'   Programm erhalten haben. Wenn nicht, siehe <http://www.gnu.org/licenses/
' 
'   Author: Oliver Skibbe ( oliskibbe at gmail.com )
'   Date: 2013-07-09
'   Purpose: Send mail to a configurable person if an calendar event is created, modified or deleted
'   Tested with: Outlook 2007
'   Hints:
'       http://www.vbarchiv.net/commands/details.php?id=formatdatetime
'       http://msdn.microsoft.com/en-us/library/office/bb208262%28v=office.12%29.aspx
'   Changelog:
'       2013-07-01 Oliver Skibbe: first release
'       2013-07-02 Oliver Skibbe: added check if private item (clear text if it is), added busy state to Output
'       2013-07-02 Oliver Skibbe: added allday check


Private WithEvents Items As Outlook.Items
Private WithEvents Reminders As Outlook.Reminders
Private WithEvents objCalFolder As Outlook.folder
Dim objDelFolder As Outlook.folder

' Helper variables
Public isDeletedBool As Boolean
Public reminderOccuredBool As Boolean

' Mail stuff
Public receiverStrg As String
Public subjectStrg As String
Public subjectPartStrg As String
Public bodyStrg As String

' Appointment helper strings
Public apptOrganizerStrg As String
Public apptLocationStrg As String
Public apptStartDateStrg As String
Public apptEndDateStrg As String
Public apptSubjectStrg As String
Public apptBodyStrg As String
Public apptBusyStateStrg As String
Public apptSensitivityStrg As String

' Translation
Public transAllDayEventStrg As String
Public transPrivateItemStrg As String
Public transAtStrg As String
Public transOfStrg As String
Public transAddedStrg As String
Public transChangedStrg As String
Public transDeletedStrg As String
Public transAvailStateStrg As String
Public transTentStateStrg As String
Public transBusyStateStrg As String
Public transOOOStateStrg As String
Public transCalendarStrg As String
Public transBodyStrg As String
Public transStateStrg As String
Public transLocationStrg As String
Public transStartStrg As String
Public transEndStrg As String

' subs
Private Sub Application_Startup()

  ' Receiver
  receiverStrg = "change.me@example.org"
  
  ' translation...modify if needed
  transAllDayEventStrg = "Ganztägig"
  transPrivateItemStrg = "Privater Termin"
  transAtStrg = "am"
  transOfStrg = "von"
  transAddedStrg = "Hinzugefügt"
  transChangedStrg = "Geändert"
  transDeletedStrg = "Gelöscht"
  transAvailStateStrg = "Verfügbar"
  transTentStateStrg = "Mit Vorbehalt"
  transBusyStateStrg = "Beschäftigt"
  transOOOStateStrg = "Abwesend"
  transCalendarStrg = "Kalendereintrag"
  transBodyStrg = "Inhalt"
  transStateStrg = "Status"
  transLocationStrg = "Ort"
  transStartStrg = "Start"
  transEndStrg = "Ende"
  
  Dim Ns As Outlook.NameSpace
  Dim CalFolder As Outlook.MAPIFolder
  Set Reminders = Outlook.Application.Reminders
  
  ' default values ..
  isDeletedBool = False
  reminderOccuredBool = False
    
  Set Ns = Application.GetNamespace("MAPI")
  Set CalFolder = Ns.GetDefaultFolder(olFolderCalendar)
  ' Set Folder = CalFolder.Folders("Subfolder")
  Set Items = CalFolder.Items
  
  Set objCalFolder = Application.Session.GetDefaultFolder(olFolderCalendar)
  Set objDelFolder = Application.Session.GetDefaultFolder(olFolderDeletedItems)
  
End Sub

' item add event
Private Sub Items_ItemAdd(ByVal Item As Object)
    ' Objects
    Dim Appt As Outlook.AppointmentItem
    
    ' if meeting or appointment..
    If TypeOf Item Is Outlook.AppointmentItem Or TypeOf Item Is Outlook.MeetingItem Then
        ' Appointment properties
        Set Appt = Item
        ' mail strings
        apptOrganizerStrg = Appt.Organizer
        ' AllDayEvent
        If Appt.AllDayEvent = True Then
            apptStartDateStrg = transAllDayEventStrg + ", " + FormatDateTime(Appt.Start, 1)
            ' we have to subtract one day to get a nice looking result
            apptEndDateStrg = transAllDayEventStrg + ", " + FormatDateTime(DateAdd("d", -1, Appt.End), 1)
        Else
            apptStartDateStrg = FormatDateTime(Appt.Start, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.Start, 1)
            apptEndDateStrg = FormatDateTime(Appt.End, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.End, 1)
        End If
        apptLocationStrg = Appt.Location
        apptBusyStateStrg = format(Appt.BusyStatus)
        apptSensitivityStrg = format(Appt.Sensitivity)
        apptBodyStrg = Appt.Body
        apptSubjectStrg = Appt.Subject
        subjectPartStrg = transAddedStrg
        
        ' send mail
        Call sendMail
    End If
End Sub

' busy state mapping
'   olBusy          2   The user is busy.
'   olFree          0   The user is available.
'   olOutOfOffice   3   The user is out of office.
'   olTentative     1   The user has a tentative appointment scheduled.
Private Sub busyState()
    Select Case apptBusyStateStrg
        Case Is = 0
            apptBusyStateStrg = transAvailStateStrg
        Case Is = 1
            apptBusyStateStrg = transTentStateStrg
        Case Is = 2
            apptBusyStateStrg = transBusyStateStrg
        Case Is = 3
            apptBusyStateStrg = transOOOStateStrg
        End Select
End Sub

' check if an calendar item is about to be deleted
Private Sub objCalFolder_BeforeItemMove(ByVal Item As Object, ByVal MoveTo As MAPIFolder, Cancel As Boolean)

    ' Objects
    Dim Appt As Outlook.AppointmentItem

    ' if meeting or appointment..
    If TypeOf Item Is Outlook.AppointmentItem Or TypeOf Item Is Outlook.MeetingItem Then
        ' Appointment properties
        Set Appt = Item
        
        ' saving calendar values for later purposes
        apptOrganizerStrg = Appt.Organizer
        ' AllDayEvent
        If Appt.AllDayEvent = True Then
            apptStartDateStrg = transAllDayEventStrg + ", " + FormatDateTime(Appt.Start, 1)
            ' we have to subtract one day to get a nice looking result
            apptEndDateStrg = transAllDayEventStrg + ", " + FormatDateTime(DateAdd("d", -1, Appt.End), 1)
        Else
            apptStartDateStrg = FormatDateTime(Appt.Start, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.Start, 1)
            apptEndDateStrg = FormatDateTime(Appt.End, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.End, 1)
        End If
        apptLocationStrg = Appt.Location
        apptBusyStateStrg = format(Appt.BusyStatus)
        apptSensitivityStrg = format(Appt.Sensitivity)
        apptBodyStrg = Appt.Body
        apptSubjectStrg = Appt.Subject
    End If
    
    ' check if item is deleted
    If MoveTo Is Nothing Then
        isDeletedBool = True
        Call Items_ItemChange(Item)
    ElseIf MoveTo = objDelFolder Then
        isDeletedBool = True
        Call Items_ItemChange(Item)
    End If
End Sub

Private Sub Items_ItemChange(ByVal Item As Object)
   
    ' Objects
    Dim Appt As Outlook.AppointmentItem
    
    ' if meeting or appointment..
    If TypeOf Item Is Outlook.AppointmentItem Or TypeOf Item Is Outlook.MeetingItem Then
    
        ' leave sub if just a reminder occured ( is set by: Sub Reminders_BeforeReminderShow )
        If reminderOccuredBool = True Then
            Exit Sub
        End If

        Set Appt = Item
        
        ' is set by Sub objCalFolder_BeforeItemMove
        If isDeletedBool = False Then
            apptOrganizerStrg = Appt.Organizer
            ' AllDayEvent
            If Appt.AllDayEvent = True Then
                apptStartDateStrg = transAllDayEventStrg + ", " + FormatDateTime(Appt.Start, 1)
                ' we have to subtract one day to get a nice looking result
                apptEndDateStrg = transAllDayEventStrg + ", " + FormatDateTime(DateAdd("d", -1, Appt.End), 1)
            Else
                apptStartDateStrg = FormatDateTime(Appt.Start, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.Start, 1)
                apptEndDateStrg = FormatDateTime(Appt.End, 4) + " " + transAtStrg + " " + FormatDateTime(Appt.End, 1)
            End If
            apptLocationStrg = Appt.Location
            apptSensitivityStrg = format(Appt.Sensitivity)
            apptBusyStateStrg = format(Appt.BusyStatus)
            apptBodyStrg = Appt.Body
            apptSubjectStrg = Appt.Subject
            subjectPartStrg = transChangedStrg
        Else
            ' part of subject
            subjectPartStrg = transDeletedStrg
        End If
  
        ' send mail
        Call sendMail
    End If
End Sub

' Before reminder is shown, set variable to surpress ItemChange
Private Sub Reminders_BeforeReminderShow(Cancel As Boolean)
    reminderOccuredBool = True
End Sub

' finally prepare and send mail
'       olConfidential  3   Confidential
'       olNormal        0   Normal sensitivity
'       olPersonal      1   Personal
'       olPrivate       2   Private
Private Sub sendMail()
    
    Dim OutApp As Object
    Dim OutMail As Object

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    ' default values for body and location string
    If LenB(apptBodyStrg) = 0 Or apptSensitivityStrg > 0 Then
        apptBodyStrg = "-"
    End If
    If LenB(apptLocationStrg) = 0 Or apptSensitivityStrg > 0 Then
        apptLocationStrg = "-"
    End If
    If LenB(apptSubjectStrg) = 0 Or apptSensitivityStrg > 0 Then
        apptSubjectStrg = "-"
    End If
    If apptSensitivityStrg > 0 Then
        subjectPartStrg = transPrivateItemStrg + ": " + subjectPartStrg
    End If
    
    ' busy State string mapping
    Call busyState
    
    ' Subject
    subjectStrg = subjectPartStrg + ": " + transCalendarStrg + " " + Chr(34) + apptSubjectStrg + Chr(34) + " " + transOfStrg + " " + apptOrganizerStrg
    ' Body
    bodyStrg = subjectPartStrg + ": " + transCalendarStrg + " " + Chr(34) + apptSubjectStrg + Chr(34) + " " + transOfStrg + " " + apptOrganizerStrg + vbCrLf _
                    + vbCrLf _
                    + transStartStrg + ": " + apptStartDateStrg + vbCrLf _
                    + transEndStrg + ": " + apptEndDateStrg + vbCrLf _
                    + transStateStrg + ": " + apptBusyStateStrg + vbCrLf _
                    + transLocationStrg + ": " + apptLocationStrg + vbCrLf _
                    + vbCrLf _
                    + transBodyStrg + ": " + apptBodyStrg
                    
    With OutMail
        .To = receiverStrg
        .Subject = subjectStrg
        .Body = bodyStrg
        .Display
        .Send
    End With
End Sub

Der Code muss in den Visual-Basic Editor (Alt+F11) unter: Projekt1 -> Microsoft Office Outlook -> ThisOutlookSession beim Kalendereigentümer eingebunden werden.

Ich hoffe es hilft einigen Leuten, gerade der Part mit gelöschten Mails war etwas knifflig.



Bei Fragen zu dem Code kontaktiert mich bitte