1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93
| Dim objOutlook
Dim objNameSpace
Dim objFolder
Dim MyItems
Dim CurrentAppointment
Dim strOutput
' Positionnement des variables / constantes----------------------------------------------------------
olMailItem = 0
olTaskItem = 3
olFolderTasks = 13
olFolderCalender = 9
olFree = 0
olTentative = 1
olBusy = 2
olOutOfOffice = 3
boolSuccess = 0
' Récupération du nom d'utilisateur loggé-------------------------------------------------------------
Set objNetwork = WScript.CreateObject("WScript.Network")
strUserName = objNetwork.username
Set objFileSystem = WScript.CreateObject("Scripting.FileSystemObject")
Set objOutPutFile = objFileSystem.CreateTextFile(strUserName & ".data", True)
Set objFtpCmdFile = objFileSystem.CreateTextFile("ftpagenda.cmd", True)
Set objOutlook = WScript.CreateObject("Outlook.application")
Set objNameSpace = objOutlook.GetNameSpace("MAPI")
Set shellCmd = WScript.CreateObject("WScript.Shell")
' On test 10 fois une connexion au serveur FTP--------------------------------------------------------
While intCount < 10
Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}!\\").ExecQuery("select * from Win32_PingStatus where address = 'url.de.mon.serveur.ftp'")
For Each objStatus in objPing
If objStatus.Statuscode = 0 Then
' Il y a une connexion réseau (réussite du ping)
' On se connecte au calendrier Outlook de l'utilisateur sur le poste
Set objFolder = objNameSpace.GetDefaultFolder(olFolderCalender)
Set MyItems = objFolder.Items
' Calcul de l'intervalle dans lequel on va exporter l'agenda
strDateStart = DateAdd("d", +0, date)
strDateEnd = DateAdd("d", +28, date)
' On recherche les rendez-vous correspondant à l'intervalle
Set objCurrentAppointment = MyItems.Find("[Start] >= """ & strDateStart & """ and [Start] <= """ & strDateEnd & """")
' Tant qu'il y a un rendez-vous
While TypeName(objCurrentAppointment) <> "Nothing"
' Et si celui-ci correspond a un état occupé ou absent
If objCurrentAppointment.BusyStatus = olBusy Or objCurrentAppointment.BusyStatus = olOutOfOffice Then
' Ecriture du fichier d'export au format texte
objOutPutFile.WriteLine objCurrentAppointment.Start & vbTab & objCurrentAppointment.End & vbTab & objCurrentAppointment.Subject & vbTab & objCurrentAppointment.Location & vbTab & objCurrentAppointment.Categories & vbTab & objCurrentAppointment.AllDayEvent
End If
Set objCurrentAppointment = MyItems.FindNext
Wend
' On ferme tout
objOutPutFile.Close
Set objFolder = Nothing
Set objMsg = Nothing
' Création du fichier de commandes FTP
With objFtpCmdFile
.WriteLine "utilisateurFtp"
.WriteLine "motdepasseFtp"
.WriteLine "PUT *.data"
.WriteLine "DISCONNECT"
.WriteLine "QUIT"
.Close
End With
' On envoie le fichier en FTP et on le supprime du poste
' On attend la fin de l'exécution (option true), et on masque la fenêtre (option 0)
shellCmd.Run "ftp -v -s:ftpagenda.cmd url.de.mon.serveur.ftp", 0, true
' Suppression des fichiers cmd et data (sécurité)
objFileSystem.deleteFile("*.data")
objFileSystem.deleteFile("*.cmd")
boolSuccess = 1
End If
Next
' On compte le nombre de tentatives, en cas de succès on arrête
intCount = intCount + 1
If (boolSuccess) Then
intCount = 10
End If
Wend |
Partager