Au Fil du Temps

---

---

***** Archivage Messagerie *****
en VBSCRIPT



Environnement	:	Windows XP
Niveau		:	Débutant 
Description	:	Sauvegarde la messagerie sous Outlook Express ( version 5 et ultérieure)
			Le script créer un raccourci "Archivage messagerie"  sur le bureau 
			pour l'éxécution de l'archivage et le répertoire de destination est 
			"Mes Documents" du profil utilisateur.
			Arborescence : 
			Mes documents
				|_ Archive
					|_ Archivage Messagerie.vbs	<--- Script Archivage
					|_ Mail
					     |_ Date
						|_ Login-utilisateur
								|_ *.dbx
 	
			L'archivage est distincte selon la date du jour.Si le raccourci 
			"Archivage messagerie" créer sur le bureau est supprimé, une 
			réexecution du script archivage situé ci-dessus permet sa recréation.
			Ce script fait office d'une procédure d'installation et de traitement.
Contrainte	:	Pris en compte d'un seul profil (identité)




On Error resume Next

Const NAMEARCHIVEDIRECTORY	= "Archive"			'Nom du répertoire Archivage selon l'arborescence ci-dessus
Const NAMEARCHIVEDIRECTORYMAIL 	= "Mail"			'Nom du répertoire Mail selon l'arborescence ci-dessus	
Const SCRIPTARCHIVAGE    	= "Archivage Messagerie.vbs"	'Nom du Script Archivage
Const NAMELINKARCHIVAGE		= "Archivage Messagerie"	'Nom du raccourci sur le Bureau vers le Script Archivage

Dim objWSH			'Objet Shell du WSH pour la manipulation de la registry et variables environnement
Dim objFSO			'Objet FSO du WSH pour la gestion du Système de Fichiers
Dim strPersonal			'Chemin du répertoire spécial "Mes Documents"
Dim strDesktop			'Chemin du répertoire spécial "Bureau"
Dim strStorageRoot		'Chemin du Dossier de Stockage Outlook Express"
Dim DirectoryArchivage		'Chemin du répertoire Archivage selon l'arborescence ci-dessus
Dim DirectoryArchivageMail	'Chemin du répertoire Mail selon l'arborescence ci-dessus
Dim strDate			'Date du Jour pour l'archivage
Dim DestDateMail		'chemin de destination pour l'éxécution du script archivage


Algorythme:

1. Récupération du chemin complet pour le répertoire personnel,le bureau et le dossier de stockage d'Outlook Express 
2. Si le dossier de stockage inexistant Alors
3.     Afficher "Votre compte de messagerie n'est pas paramétrer pour Outlook Express"
4. Sinon
5. 	Création de l'arborescence de l'archivage à partir du répertoire personnel de l'utilisateur (Mes Documents)
6. 	Si le raccourci "Archivage Messagerie" sur le bureau est inexistant Alors
7.		Création du raccourci vers le script archivage ("Archivage messagerie.vbs") pour son éxécution
8.	Sinon
9.		Exécution du lien par l'utilisateur --> Archivage de la messagerie avec la date du jour 
10.	FinSi
11. FinSi


*** ETAPE 1 à 8 INSTALLATION DU SCRIPT ***
'Création d'une instance SHELL et FSO du WSH
set objWSH   = WScript.CreateObject("WScript.Shell")
set objFSO   = WScript.CreateObject("Scripting.FileSystemObject")

'Localisation des répertoires spéciaux associés à l'utilisateur
strPersonal  = GetFullPath(objWSH.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Personal"))
strDesktop    = GetFullPath(objWSH.RegRead("HKCU\Software\Microsoft\Windows\CurrentVersion\Explorer\Shell Folders\Desktop"))
strDefaultUserId    = objWSH.RegRead("HKCU\Identities\Default User ID")
strStorageRoot = GetFullPath(objWSH.RegRead("HKCU\Identities\" & strDefaultUserId & "\Software\Microsoft\Outlook Express\5.0\Store Root"))

'Si Outlook Express non paramétrer alors Fin du script
If strStorageRoot = "" Then
	Msgbox "Votre compte de messagerie n'est pas paramétrer pour Outlook Express."
	Wscript.Quit
End If

'Assignation des répertoires archivages à créer
DirectoryArchivage	= strPersonal & "\" & NAMEARCHIVEDIRECTORY
DirectoryArchivageMail  = DirectoryArchivage & "\" & NAMEARCHIVEDIRECTORYMAIL

'Création de l'arborescence archivage à partir du répertoire personnel
If Not objFSO.FolderExists(DirectoryArchivage) Then
	objFSO.CreateFolder(DirectoryArchivage)
End If

If Not objFSO.FolderExists(DirectoryArchivageMail) Then
	objFSO.CreateFolder(DirectoryArchivageMail)	
End if

If NOT objFSO.FileExists(DirectoryArchivage & "\" & SCRIPTARCHIVAGE) Then
	objFSO.CopyFile SCRIPTARCHIVAGE,DirectoryArchivage & "\"
End If

'Création du raccourci "Archivage Messagerie" sur le Bureau si inexistant ou supprimer
'Etape installation terminé.L'archivage se fait normalement par le raccourci .

If NOT objFSO.FileExists(strDesktop & "\" & NAMELINKARCHIVAGE & ".lnk") Then
	CreateShortcutArchiveMail DirectoryArchivage,SCRIPTARCHIVAGE,NAMELINKARCHIVAGE 
	Wscript.Quit
End If

*** ETAPE 9 TRAITEMENT ARCHIVAGE ***
'Archivage des mails à la date du jour

strDate = formatDateTime(Date,1)  
DestDateMail = DirectoryArchivageMail & "\" & strDate & "\"

If NOT objFSO.FolderExists(DestDateMail) Then
	 objFSO.CreateFolder(DestDateMail)
End if

'Copie animé du répertoire de stockage d'Outlook Express FOF_CREATEPROGRESSDLG = 0
'Autres options diponibles non utilisé dans ce script
<dec>	<hexa>	<commentaire>

0	&H0	Display a progress dialog box.
4	&H4	Do not display a progress dialog box.
8  	&H8	Give the file being operated on a new name in a move, copy,
		or rename operation if a file with the target name already exists.
16 	&H10	Respond with "Yes to All" for any dialog box that is displayed.
64	&H40	Preserve undo information, if possible.
128	&H80	Perform the operation on files only if a wildcard file name (*.*) is specified.
256	&H100	Display a progress dialog box but do not show the file names.
512	&H200	Do not confirm the creation of a new directory if the operation requires one to be created.
1024	&H400	Do not display a user interface if an error occurs.
2048	&H800	Version 4.71. Do not copy the security attributes of the file.
4096	&H1000	Only operate in the local directory. Don't operate recursively into subdirectories.
9182	&H23DE	Version 5.0. Do not copy connected files as a group. Only copy the specified files.


Const FOF_CREATEPROGRESSDLG = &H0
ParentFolder = DestDateMail
Set objShell = CreateObject("Shell.Application")
Set objFolder = objShell.NameSpace(ParentFolder)
objFolder.CopyHere strStorageRoot, FOF_CREATEPROGRESSDLG

Msgbox VbTab & VbTab &  VbTab & "    Archivage  terminer..." & VbCrLf & VbCrLf & "vers " &  DestDateMail

*** PROCEDURES ET FONCTIONS ***
// -------------- CreateShortcutArchiveMail(DIRECTORY,FILE,StrNameLnk) -----------------------
// Description	: Création d'un raccourci sur le Bureau utilisateur
// Entree 	:
//		 - DIRECTORY : Répertoire de Travail
//		 - FILE	     : Fichier cible -> "Archivage Messagerie.vbs"
//		 - StrNameLnk: Nom du raccourci
// Sortie	: Lien vers le script Archivage
//-------------------------------------------------------------
Sub CreateShortcutArchiveMail(DIRECTORY,FILE,StrNameLnk)
   Dim strDesktop,objLnkArchiveMail
   strDesktop      	      = objWSH.SpecialFolders("Desktop")
   set objLnkArchiveMail 	      = objWSH.CreateShortcut(strDesktop & "\" & StrNameLnk & ".lnk")
   objLnkArchiveMail.TargetPath   = DIRECTORY & "\" & FILE
   objLnkArchiveMail.WindowStyle  = 1
   objLnkArchiveMail.Hotkey       = "CTRL+ALT+M"
   objLnkArchiveMail.IconLocation = "%SystemRoot%\system32\SHELL32.dll,34"
   objLnkArchiveMail.Description  = "Sauvegarde de la messagerie" & FILE
   objLnkArchiveMail.WorkingDirectory = DIRECTORY 
   objLnkArchiveMail.Save
   Set  objLnkArchiveMail = Nothing
End Sub

// -------------- GetFullPath(strPath) -----------------------
// Description	: Soustraction des variables de substition pour déterminer la valeur
// Entree 	: 
//		 - strPath : Un chemin arborescent avec ou sans variable de substitution
// Sortie	: Un chemin complet
//-------------------------------------------------------------

Function GetFullPath(strPath)

Dim pos1			'debut de position de la variable de substitution
Dim pos2			'Fin de position de la variable de substitution
Dim var				'Variable de substitution

pos1 = InStr(strPath,"%") 
pos2 = InStrRev(strPath,"%")

If pos1 = 0 Then		'Pas de variable de substition dans le chemin
	GetFullPath = strPath	'Retourne le chemin et fin de la fonction
	Exit Function
End if

var  = mid(strPath,pos1 + 1,pos2 - 2 )	'Extraction de la variable de substitution

	Set wshEnv = objWSH.Environment("PROCESS")
	If wshEnv(var) <> "" Then
	        strVar  =    objWSH.ExpandEnvironmentStrings(wshEnv(var))
	else
	strVar = wshEnv(var)		'Récupération de la valeur d'une variable 
	End If

GetFullPath = strVar & mid(strPath,pos2 + 1,len(strPath) - pos2 ) 'Retourne un chemin complet	

End Function

set objWSH 	= Nothing
set objFSO 	= Nothing
set objShell	= Nothing
set objFolder	= Nothing



*** Téléchargez le script Archivage Messagerie ***

1.Décompressez archivagemessagerie.zip dans un répertoire quelconque
2.Exécuter le fichier "Archivage Messagerie.vbs" 
3.Utiliser le raccourci "Archivage Messagerie" qui a été créé sur le Bureau