'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+
' - THIS LOGON VBSCRIPT CONVERTS OUTLOOK 2010 MAIL PROFILES SO THEY WORK WITH OUTLOOK 2007.
' - SOLVES 'You have a previous version of the Microsoft Exchange Messaging Service. Create a new profile.'
' - OUTLOOK 2007 READS MAILBOX SETTINGS FROM A REGISTRY KEY WITH A FIXED NAME BUT IN OUTLOOK 2010 THE NAME IS RANDOMLY GENERATED.
' - IF OUTLOOK 2007 IS DETECTED AND THE DEFAULT MAIL PROFILE IS SETUP FOR OUTLOOK 2010 THE SETTINGS WILL BE COPIED TO WHERE OUTLOOK 2007 EXPECTS THEM.
'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

On Error Resume Next

Const HKEY_CLASSES_ROOT    = &H80000000
Const HKEY_CURRENT_USER    = &H80000001
Const KEY_OUTLOOK_PROFILES = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles\"
Const KEY_PROFILE_INFO     = "0a0d020000000000c000000000000046"
Const KEY_MAILBOX_2007     = "13dbb0c8aa05101a9bb000aa002fc45a"

Set oReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv")
FixOutlookProfile()
Set oReg = Nothing

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

Function FixOutlookProfile()
  ' CHECK OUTLOOK 2007 IS INSTALLED
  If Not IsOutlookInstalled(12) Then Exit Function
  ' CHECK OUTLOOK 2010 IS NOT INSTALLED
  If IsOutlookInstalled(14) Then Exit Function
  ' GET DEFAULT OUTLOOK PROFILE
  defaultProfile = GetOutlookDefaultProfile()
  ' CHECK DEFAULT IS SET
  If defaultProfile = "" Then Exit Function
  ' CHECK DEFAULT EXISTS
  If Not RegistryKeyExists(HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES & defaultProfile) Then Exit Function
  ' GET OUTLOOK 2010 MAILBOX SETTINGS KEY
  mailboxKey = GetOutlookProfileMailboxKey(defaultProfile)
  ' CHECK MAILBOX IS SET
  If mailboxKey = "" Then Exit Function
  ' CHECK MAILBOX EXISTS
  If Not RegistryKeyExists(HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES & defaultProfile & "\" & mailboxKey) Then Exit Function
  ' COPY MAILBOX SETTINGS BACK INTO THE OUTLOOK 2007 KEY
  RegistryKeysCopy HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES & defaultProfile & "\" & mailboxKey, "", HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES & defaultProfile & "\" & KEY_MAILBOX_2007
  ' REMOVE PROFILE VERSION TO PREVENT DOWNGRADE WARNING
  oReg.DeleteKey HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES & defaultProfile & "\" & KEY_PROFILE_INFO, "0003036f"
End Function

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

Function IsOutlookInstalled(versionNumber)
  IsOutlookInstalled = False
  oReg.GetStringValue HKEY_CLASSES_ROOT, "Outlook.Application." & versionNumber & "\CLSID\", "", tempValue
  If IsNull(tempValue) Then Exit Function
  If IsEmpty(tempValue) Then Exit Function
  IsOutlookInstalled = True
End Function

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

Function GetOutlookProfileMailboxKey(profileName)
  GetOutlookProfileMailboxKey = ""
  oReg.GetBinaryValue HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES & profileName & "\" & KEY_PROFILE_INFO, "01023d15", tempArray
  If IsNull(tempArray) Then Exit Function
  If Not IsArray(tempArray) Then Exit Function
  For Each tempValue In tempArray
    tempValue = LCase(Hex(tempValue))
    If Len(tempValue) < 2 Then tempValue = "0" & tempValue
    GetOutlookProfileMailboxKey = GetOutlookProfileMailboxKey & tempValue
  Next
End Function

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

Function GetOutlookDefaultProfile()
  oReg.GetStringValue HKEY_CURRENT_USER, KEY_OUTLOOK_PROFILES, "DefaultProfile", GetOutlookDefaultProfile
  If IsNull(GetOutlookDefaultProfile) Then GetOutlookDefaultProfile = ""
End Function

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

Function RegistryKeyExists(registryHive, registryKeyPath)
  RegistryKeyExists = False
  If oReg.EnumValues(registryHive, registryKeyPath, "", "") = 0 Then RegistryKeyExists = True
End Function

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+

Function RegistryKeysCopy(registryHive, registryKeyPath, relativeKeyPath, registryTargetHive, registryTargetPath)
  oReg.EnumKey registryHive, registryKeyPath, aSubKeys
  If IsArray(aSubKeys) Then
    For Each subKey In aSubKeys
      oReg.CreateKey registryTargetHive, registryTargetPath & relativeKeyPath & "\" & subKey
      RegistryKeysCopy registryHive, registryKeyPath & "\" & subkey, relativeKeyPath & "\" & subKey, registryTargetHive, registryTargetPath
    Next
  End If
  oReg.EnumValues registryHive, registryKeyPath, aValueNames, aValueTypes
  If IsArray(aValueNames) Then
    For i = 0 To UBound(aValueNames)
      Select Case aValueTypes(i)
        Case 1  ' REG_SZ
          oReg.GetStringValue registryHive, registryKeyPath, aValueNames(i), tempValue
          oReg.SetStringValue registryTargetHive, registryTargetPath & relativeKeyPath, aValueNames(i), tempValue
        Case 2  ' REG_EXPAND_SZ
          oReg.GetExpandedStringValue registryHive, registryKeyPath, aValueNames(i), tempValue
          oReg.SetExpandedStringValue registryTargetHive, registryTargetPath & relativeKeyPath, aValueNames(i), tempValue
        Case 3  ' REG_BINARY
          oReg.GetBinaryValue registryHive, registryKeyPath, aValueNames(i), tempValue
          oReg.SetBinaryValue registryTargetHive, registryTargetPath & relativeKeyPath, aValueNames(i), tempValue
        Case 4  ' REG_DWORD
          oReg.GetDWORDValue registryHive, registryKeyPath, aValueNames(i), tempValue
          oReg.SetDWORDValue registryTargetHive, registryTargetPath & relativeKeyPath, aValueNames(i), tempValue
        Case 7  ' REG_MULTI_SZ
          oReg.GetMultiStringValue registryHive, registryKeyPath, aValueNames(i), tempValue
          oReg.SetMultiStringValue registryTargetHive, registryTargetPath & relativeKeyPath, aValueNames(i), tempValue
        Case 11 ' REG_QWORD
          oReg.GetQWORDValue registryHive, registryKeyPath, aValueNames(i), tempValue
          oReg.SetQWORDValue registryTargetHive, registryTargetPath & relativeKeyPath, aValueNames(i), tempValue
      End Select
    Next
  End If
End Function

'-----------------------------------------------------------------------------------------------------------------------------------------------------------------------------+