Da qui a breve un’azienda con qualche migliaio di utenti cambierà il suo dominio di posta.
Gli utenti di posta sono sparsi geograficamente su server Domino, Exchange e in hosting presso alcuni ISP.
La Fastnet ha ricevuto l’incarico di seguire il progetto di migrazione e allo scopo ha implementato un laboratorio virtuale basato su VMware ESX in cui è stata riprodotta l’infrastruttura di messaggistica del cliente.
Oltre a supportare la fase di coesistenza del vecchio dominio e del nuovo e di prevedere il consolidamento di alcuni domini, ci è stato anche richiesto di prevedere la modifica del cambio dell’indirizzo internet sulla postazione di ciascun utente.
Gli utenti usano come client di posta sia Lotus Notes, che Microsoft Outlook e Outlokk Express.
Per gli utenti Lotus Notes che dovranno cambiare il proprio email da <nome.cognome@vecchiodominio.com> a <nome.cognome@nuovodominio.com> si utilizzerà del codice LotusScript associato ad un pulsante che gli utenti troveranno all’interno di una email.
L’utente che riceve tale email fa click sul pulsante in essa contenuto e lo script provvederà a modificare con il nuovo dominio tutti i campi contenente l’email address presenti nei documenti di Location del proprio personal address book. La procedura invia anche un email di conferma ad un amministratore.
Sub Click(Source As Button) Dim s As New NotesSession Dim view As NotesView Dim doc As NotesDocument Dim newDomain As String Dim oldDomain As String Dim toNotify As String toNotify = "user admin/xxxxxxx" newDomain = "@newdoamin.com" oldDomain = "@olddomain.com" sNamesLine=s.GetEnvironmentString("NAMES", True) nPos = Instr(sNamesLine, ",") If nPos > 0 Then sNamesLine = Left$(sNamesLine, nPos-1) Else sNamesLine = "names.nsf" End If Set db = New NotesDatabase( "",sNamesLine ) If Not(db.isOpen) Then Messagebox "Non è stato possibile aggiornare automaticamente il sistema. Può gentilmente contattare l'help desk? Spieghi che ha ricevuto un codice KO55" Exit Sub End If Set view = db.GetView("Locations") Dim email, domain, predomain As String Dim message As String message = "" Set doc = view.GetFirstDocument While Not doc Is Nothing If doc.HasItem("ImailAddress") Then email=doc.ImailAddress(0) domain = Strtoken(email, "@", 2) If domain = oldDomain Then predomain = Strtoken(email, "@", 1) email = predomain + newDomain message = message + " Aggiornata la location: " + doc.Name(0) + Chr(10) Call doc.ReplaceItemValue("ImailAddress", email) Call doc.Save(True, False) End If End If Set doc = view.GetNextDocument(doc) Wend Dim arrSendTo(0 To 0) As String Dim arrCopyTo(0 To 0) As String Dim arrBlindCopyTo(0 To 0) As String Dim txtSubject As String Dim txtBody As String txtSubject = {Notifica aggiornamento location per } + s.CommonUserName txtBody = message arrSendTo(0) = toNotify arrCopyTo(0) = {} arrBlindCopyTo(0) = {} 'Try sending the mail If message <> "" Then If fnSendMailWithDocLink(arrSendTo,arrCopyTo,arrBlindCopyTo,txtSubject,txtBody,Nothing) Then 'Success Print "Email spedita" Messagebox "Aggiornamenti effettuati. Grazie per la collaborazione." Else 'Failure Print "Email NON spedita" Messagebox "Aggiornamenti effettuati. Grazie per la collaborazione." Messagebox "Non è stato possibile notificare automaticamente il responsabile di sistema. Può gentilmente contattare l'help desk? Spieghi che ha ricevuto un codice OK88" End If Else Messagebox "Non sono necessari aggiornamenti. Grazie per la collaborazione." End If End Sub Function fnSendMailWithDocLink(pSendTo() As String, pCopyTo() As String, _ pBlindCopyTo() As String, Byval pSubject As String, Byval pBody As String, _ pDocLink As NotesDocument) As Integer On Error Goto ErrorHandler Dim session As New NotesSession Dim db As NotesDatabase Dim docMemo As NotesDocument Dim rtitemBody As NotesRichTextItem Set db = session.CurrentDatabase Set docMemo = db.CreateDocument docMemo.Form = "Memo" docMemo.SendTo = pSendTo docMemo.CopyTo = pCopyTo docMemo.BlindCopyTo = pBlindCopyTo docMemo.Subject = pSubject Set rtitemBody = docMemo.CreateRichTextItem("Body") Call rtitemBody.AppendText(pBody) If Not(pDocLink Is Nothing) Then Call rtitemBody.AddNewLine(2) Call rtitemBody.AppendText({Click to open the document =>}) Call rtitemBody.AppendDocLink(pDocLink, "Click to open the document") End If Call docMemo.Send(False) fnSendMailWithDocLink = True Exit Function ErrorHandler: 'Some error occurred. Handle errors below... '... '... '... 'Return false, because an error occured fnSendMailWithDocLink = False Exit Function 'Abnormal exit End Function
Nel caso invece di Outlook e Outlook Express le cose sono leggermente più complicate soprattutto per le diverse versioni dei programmi utilizzate.
Allo scopo ho sviluppato uno script che verrà eseguito sui vari pc nella fase di logon.
Lo script che segue supporta Outlook su Windows 2000/XP e Vista.
Supporta Outlook Express su Windows 2000 e XP.
Non supporta (ma ci sto lavorando) Windows Mail (che su Vista sostituisce Outlook Express).
'========================================================================== ' ' NAME: OutEmailDomChg.vbs ' ' AUTHOR: Filippo Del Prete - Fastnet spa ' BASED ON: Multiple, Luke Edson, Edsontech ' DATE : 23-12-2008 ' ' COMMENT: VBScript to change domain part in Outlook email (2000 to 2007). ' from <no-change>@OLD_DOMAIN to <no-change>@NEW_DOMAIN ' ' IMPORTANT: Read Notes section ' ' You have a royalty-free right to use, modify, reproduce, and ' distribute this script file in any way you find useful, provided ' that you agree that the copyright owner above has no warranty, ' obligations, or liability for such use. ' '========================================================================== ' *Notes* ' Outlook versions 2000, 2002(XP), 2003 and 2007 are supported ' Windows 2000/XP/2003/Vista are supported ' This script uses CDO.Message object to send an email: see Email settings below ' domain to manage Const OLD_DOMAIN = "olddomain.com" Const NEW_DOMAIN = "newdomain.com" ' Set constants for Registry Const HKEY_CLASSES_ROOT = &H80000000 Const HKEY_CURRENT_USER = &H80000001 Const HKEY_LOCAL_MACHINE = &H80000002 ' EMail settings Const SMTP_SERVERNAME = "xxx.yyyy.it" Const FROM_EMAIL = "f.delprete@zzzzzzz.it" Const TO_EMAIL = "f.delprete@kkkkkkkk.it" Dim objReg, strOutPath, strVerPath, strComputer, strEntryName, strVersion, strOut Dim ArgObj Dim objEnv ' as collection Dim WshShell Dim msgText Dim msg Dim OutlookInstalled Dim OutExprInstalled OutlookNotInstalled = False OutExprNotInstalled = False msg = "Looking for " & OLD_DOMAIN & " and trying to change in " & NEW_DOMAIN wscript.echo msg msgText = msgText & msg & vbCRLF Set objReg = GetObject("winmgmts:{impersonationLevel=impersonate}!\\.\root\default:StdRegProv") Set WshShell = WScript.CreateObject("WScript.Shell") ' Set Values for Registry information strOutPath = "Outlook.Application\CurVer" strVerPath = "SYSTEM\CurrentControlSet\Control\ProductOptions" strOLProfKey = "Software\Microsoft\Windows NT\CurrentVersion\Windows Messaging Subsystem\Profiles" strOEProfKey = "HKCU\Software\Microsoft\Internet Account Manager\Account Name" strEntryName = "ProductType" ' Read Environment Variables strOS = WshShell.ExpandEnvironmentStrings("%OS%") strUsername = WshShell.ExpandEnvironmentStrings("%USERNAME%") strComputername = WshShell.ExpandEnvironmentStrings("%COMPUTERNAME%") ' check for Outlook installed objReg.GetStringValue HKEY_CLASSES_ROOT, strOutPath, "", strOut strOut = strOut & "" If strOut = "" Then msg = "Outlook is not installed" wscript.echo msg msgText = msgText & msg & vbCRLF OutlookNotInstalled = True End If 'check for Outlook Express newAccountNum = WshShell.RegRead(strOEProfKey) If newAccountNum = "" Then msg = "Outlook Express never used" wscript.Echo msg msgText = msgText & msg & vbCRLF OutExprNotInstalled = True End if If OutlookNotInstalled and OutExprNotInstalled Then msg = "Neither Outlook Express or Outlook used" wscript.Echo msg msgText = msgText & msg & vbCRLF Call SendTheEmail(TO_EMAIL,FROM_EMAIL,"Outlook change domain result: " & strUsername & " (" & strComputername & ")", SMTP_SERVERNAME, msgText) wscript.quit End if ' check for Windows NT/2000/XP If strOS = "Windows_NT" then Else msg = "This script does not run on Windows 9X" wscript.echo msg msgText = msgText & msg & vbCRLF Call SendTheEmail(TO_EMAIL,FROM_EMAIL,"Outlook change domain result: " & strUsername & " (" & strComputername & ")", SMTP_SERVERNAME, msgText) wscript.quit End If ' check for Workstation/Professional vs. Server versions objReg.GetStringValue HKEY_LOCAL_MACHINE, strVerPath, strEntryName, strVer If strVer = "WinNT" then msg = "This is a workstation" wscript.echo msg msgText = msgText & msg & vbCRLF Else msg = "This is a Server - Quitting" wscript.echo msg msgText = msgText & msg & vbCRLF Call SendTheEmail(TO_EMAIL,FROM_EMAIL,"Outlook change domain result: " & strUsername & " (" & strComputername & ")", SMTP_SERVERNAME, msgText) wscript.quit End if If OutlookNotInstalled = False Then ' Check for listing default Profile to determine if Profile exists objReg.getStringValue HKEY_CURRENT_USER, strOLProfKey, "DefaultProfile", strDefProf msg = "Declared Outlook DefaultProfile: " & strDefProf wscript.echo msg msgText = msgText & msg & vbCRLF strOLProfKey = strOLProfKey & "\" & strDefProf & "\9375CFF0413111d3B88A00104B2A6676" objReg.EnumKey HKEY_CURRENT_USER, strOLProfKey, arrProfileKeys If IsNull(arrProfileKeys) then 'If #3 msg = "Profile does not exist" wscript.echo msg msgText = msgText & msg & vbCRLF Else msg = "Outlook Profile Exists" wscript.echo msg msgText = msgText & msg & vbCRLF If strOut = "Outlook.Application.11" or strOut = "Outlook.Application.10" then msg = "Outlook 2002/2003" wscript.echo msg msgText = msgText & msg & vbCRLF For Each subkey In arrProfileKeys strSubkeyPath = strOLProfKey & "\" & subkey ' wscript.echo "strsubkey: " & strSubkeyPath ' 001f300a value contains name of the service DLL file objReg.GetBinaryValue HKEY_CURRENT_USER, strSubkeyPath, "Email", emailValue strhexkeyvalue="" If Not IsNull(emailValue) Then For i = 0 To UBound(emailValue) ' build string from hex values strhexkeyvalue = strhexkeyvalue & HexByte(emailValue(i)) Next theEmail = Hex4ToString(strhexkeyvalue) theEmail = Mid(theEmail,1,Len(theEmail)-1) testRes = StrComp(OLD_DOMAIN,Trim(Mid(theEmail,InStr(1,theEmail,"@")+1))) if testRes = 0 then msg = "Email found in the old domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF startEmail = Mid(theEmail,1,InStr(1,theEmail,"@")) newEmail = startEmail & NEW_DOMAIN msg = "Rewriting the email address with the new domain: " & newEmail wscript.echo msg msgText = msgText & msg & vbCRLF myEmailArray = StringToByteArray(newEmail, True) objreg.SetBinaryValue HKEY_CURRENT_USER, strSubkeyPath, "Email", myEmailArray Else msg = "Email found in a non-matching domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF End if ' Exit For End If Next Elseif strOut = "Outlook.Application.9" then msg = "Outlook 2000 - Da Testare" wscript.echo msg msgText = msgText & msg & vbCRLF For Each subkey In arrProfileKeys strSubkeyPath = strOLProfKey & "\" & subkey ' wscript.echo "strsubkey: " & strSubkeyPath objReg.GetBinaryValue HKEY_CURRENT_USER, strSubkeyPath, "Email", emailValue strhexkeyvalue="" If Not IsNull(emailValue) Then For i = 0 To UBound(emailValue) ' build string from hex values strhexkeyvalue = strhexkeyvalue & HexByte(emailValue(i)) Next theEmail = Hex4ToString(strhexkeyvalue) theEmail = Mid(theEmail,1,Len(theEmail)-1) testRes = StrComp(OLD_DOMAIN,Trim(Mid(theEmail,InStr(1,theEmail,"@")+1))) if testRes = 0 then msg = "Email found in the old domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF startEmail = Mid(theEmail,1,InStr(1,theEmail,"@")) newEmail = startEmail & NEW_DOMAIN msg = "Rewriting the email address with the new domain: " & newEmail wscript.echo msg msgText = msgText & msg & vbCRLF myEmailArray = StringToByteArray(newEmail, True) objreg.SetBinaryValue HKEY_CURRENT_USER, strSubkeyPath, "Email", myEmailArray Else msg = "Email found in a non-matching domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF End if ' Exit For End If Next Elseif strOut = "Outlook.Application.12" then msg = "Outlook 2007" wscript.echo msg msgText = msgText & msg & vbCRLF For Each subkey In arrProfileKeys strSubkeyPath = strOLProfKey & "\" & subkey ' wscript.echo "strsubkey: " & strSubkeyPath objReg.GetBinaryValue HKEY_CURRENT_USER, strSubkeyPath, "Email", emailValue strhexkeyvalue="" If Not IsNull(emailValue) Then For i = 0 To UBound(emailValue) ' build string from hex values strhexkeyvalue = strhexkeyvalue & HexByte(emailValue(i)) Next theEmail = Hex4ToString(strhexkeyvalue) theEmail = Mid(theEmail,1,Len(theEmail)-1) testRes = StrComp(OLD_DOMAIN,Trim(Mid(theEmail,InStr(1,theEmail,"@")+1))) if testRes = 0 then msg = "Email found in the old domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF startEmail = Mid(theEmail,1,InStr(1,theEmail,"@")) newEmail = startEmail & NEW_DOMAIN msg = "Rewriting the email address with the new domain: " & newEmail wscript.echo msg msgText = msgText & msg & vbCRLF myEmailArray = StringToByteArray(newEmail, True) objreg.SetBinaryValue HKEY_CURRENT_USER, strSubkeyPath, "Email", myEmailArray Else msg = "Email found in a non-matching domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF End if ' Exit For End If Next Else msg = "This is not a supported version of Outlook" wscript.echo msg msgText = msgText & msg & vbCRLF End if End if End if ' If OutlookNotInstalled = False If OutExprNotInstalled = False Then msg = "Outlook Express found: trying to update SMTP Email Address" wscript.echo msg msgText = msgText & msg & vbCRLF For i = 1 To (newAccountNum - 1) b = "HKCU\Software\Microsoft\Internet Account Manager\Accounts\0000000" & i & "\" If (RegistryKeyExists(b)) Then theEmail = WshShell.RegRead ( b & "SMTP Email Address" ) testRes = StrComp(OLD_DOMAIN,Trim(Mid(theEmail,InStr(1,theEmail,"@")+1))) if testRes = 0 then msg = "Email found in the old domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF startEmail = Mid(theEmail,1,InStr(1,theEmail,"@")) newEmail = startEmail & NEW_DOMAIN msg = "Rewriting the email address with the new domain: " & newEmail wscript.echo msg msgText = msgText & msg & vbCRLF WshShell.RegWrite b & "SMTP Email Address" , newEmail, "REG_SZ" Else msg = "Email found in a non-matching domain: " & theEmail wscript.echo msg msgText = msgText & msg & vbCRLF End if Else msg = "Error: non existant registry key: " & b wscript.echo msg msgText = msgText & msg & vbCRLF End If Next End If Call SendTheEmail(TO_EMAIL,FROM_EMAIL,"Outlook change domain result: " & strUsername & " (" & strComputername & ")", SMTP_SERVERNAME, msgText) '********************************************************** Function HexByte(b) HexByte = Right("0" & Hex(b), 2) End Function Public Function StringToByteArray(Data, NeedNullTerminator) Dim strAll strAll = StringToHex4(Data) If NeedNullTerminator Then strAll = strAll & "0000" End If intLen = Len(strAll) \ 2 ReDim arr(intLen - 1) For i = 1 To Len(strAll) \ 2 arr(i - 1) = CByte("&H" & Mid(strAll, (2 * i) - 1, 2)) Next StringToByteArray = arr End Function Public Function RmChr(string, remove) Dim i, j, tmp, strOutput strOutput = "" for j = 1 to len(string) tmp = Mid(string, j, 1) for i = 1 to len (remove) tmp = replace(tmp, Mid(remove,i,1), "") if len(tmp) = 0 then exit for next strOutput = strOutput & tmp next RmChr = strOutput End Function Public Function StringToHex4(Data) ' Input: normal text ' Output: four-character string for each character, ' e.g. "3204" for lower-case Russian B, ' "6500" for ASCII e ' Output: correct characters ' needs to reverse order of bytes from 0432 Dim strAll For i = 1 To Len(Data) ' get the four-character hex for each character strChar = Mid(Data, i, 1) strTemp = Right("00" & Hex(AscW(strChar)), 4) strAll = strAll & Right(strTemp, 2) & Left(strTemp, 2) Next StringToHex4 = strAll End Function Public Function Hex4ToString(Data) Dim strTemp Dim strAll For i = 1 To Len(Data) Step 4 strTemp = Mid(Data, i, 4) strTemp = "&H" & Right(strTemp, 2) & Left(strTemp, 2) strAll = strAll & ChrW(CInt(strTemp)) Next Hex4ToString = strAll End Function Sub SendTheEmail(toVar, fromVar, subjectVar, serverVar, bodyVar) Set objEmail = CreateObject("CDO.Message") objEmail.From = fromVar objEmail.To = toVar objEmail.Subject = subjectVar objEmail.Textbody = bodyVar & vbCRLF & " script by FMDP - Fastnet Spa - 2008-2009" objEmail.Configuration.Fields.Item _ ("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 objEmail.Configuration.Fields.Item _ ("http://schemas.microsoft.com/cdo/configuration/smtpserver") = serverVar objEmail.Configuration.Fields.Item _ ("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25 objEmail.Configuration.Fields.Update objEmail.Send End Sub Function RegistryKeyExists (RegistryKey) 'Ensure the last character is a backslash (\) - if it isn't, we aren't looking for a key If (Right(RegistryKey, 1) <> "\") Then 'It's not a registry key we are looking for RegistryKeyExists = false Else 'If there isnt the key when we read it, it will return an error, so we need to resume On Error Resume Next 'Try reading the key WshShell.RegRead RegistryKey 'Catch the error Select Case Err 'Error Code 0 = 'success' Case 0: RegistryKeyExists = true 'This checks for the (Default) value existing (but being blank); as well as key's not existing at all (same error code) Case &h80070002: 'Read the error description, removing the registry key from that description ErrDescription = Replace(Err.description, RegistryKey, "") 'Clear the error Err.clear 'Read in a registry entry we know doesn't exist (to create an error description for something that doesnt exist) WshShell.RegRead "HKEY_ERROR\" 'The registry key exists if the error description from the HKEY_ERROR RegRead attempt doesn't match the error 'description from our RegistryKey RegRead attempt If (ErrDescription <> Replace(Err.description, "HKEY_ERROR\", "")) Then RegistryKeyExists = true Else RegistryKeyExists = false End If 'Any other error code is a failure code Case Else: RegistryKeyExists = false End Select 'Turn error reporting back on On Error Goto 0 End If End Function