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 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143
| Sub PstFiles()
Dim f As MAPIFolder
Dim feuille As Worksheet
Dim rw As Integer
Dim rep As Boolean
Dim nom As String
Set feuille = ActiveWorkbook.Worksheets("Status")
feuille.Cells(1, 2) = Application.UserName ' Nom de l'utilisateur
feuille.Cells(2, 2) = Environ$("computername") ' Nom de l'ordinateur
rw = 4 '#################### LstRows(feuille, "B")
If rw > 4 Then
feuille.Range("B5" & rw).ClearContents ' Enlève les anciennes données
Else
feuille.Range("B55").ClearContents
End If
rw = 5 ' N° de ligne pour écrire le résultat dans la feuille Excel
Dim objOL As Outlook.Application
Dim objFolders As Outlook.Folders 'As Outlook.MAPIFolders
Set objOL = CreateObject("Outlook.Application")
Set objFolders = objOL.Session.Folders
For i = objFolders.Count To 1 Step -1
Set f = objFolders(i)
nom = f.Name
rep = False
On Error Resume Next
repertoire = GetPathFromStoreID(f.StoreID) ' J'extrait le répertoire du fichier PST
On Error GoTo 0
If repertoire <> "Server" Then
reponse = MsgBox("do you want to remove " & nom & "?", vbQuestion + vbYesNo, "Question")
If reponse = vbYes Then
'rep = RemovePST(nom) ' Fonction qui retire le fichier PST
rep = DetachPST(nom, objOL)
End If
End If
feuille.Cells(rw, 2) = nom ' Affiche les résultats
feuille.Cells(rw, 3) = repertoire
If rep Then
feuille.Cells(rw, 4) = 1 ' La valeur 1 indique que le fichier est supprimé
ElseIf repertoire = "Server" Then
feuille.Cells(rw, 4) = "N/A" ' Dans le cas ou le fichier est sur le serveur, il ne faut pas supprimer donc : N / A
Else
feuille.Cells(rw, 4) = -1 ' La valeur -1 indique que le fichier n'est pas supprimé
End If
rw = rw + 1
repertoire = ""
Next i
End Sub
'2 ° code:Extrait le répertoire du fichier PST
Public Function GetPathFromStoreID(sStoreID As String) As String
On Error Resume Next
Dim i As Long
Dim lPos As Long
Dim sRes As String
For i = 1 To Len(sStoreID) Step 2
sRes = sRes & Chr("&h" & Mid$(sStoreID, i, 2))
Next
sRes = Replace(sRes, Chr(0), vbNullString)
lPos = InStr(sRes, ":\")
If lPos Then
GetPathFromStoreID = Right$(sRes, (Len(sRes)) - (lPos - 2))
Else
GetPathFromStoreID = "Server"
End If
End Function
''3 ème code:' Efface de la liste le fichier PST (passé en paramètre)
'
'Function RemovePST(PstName As String) As Boolean
' Dim objOL As Outlook.Application 'As New Outlook.Application
' Dim objFolders As Outlook.Folders 'As Outlook.MAPIFolders
' Dim objFolder As Outlook.MAPIFolder 'As Outlook.MAPIFolder
'
' Dim i 'As Interger
' Dim strPrompt 'As String
'
' Set objOL = CreateObject("Outlook.Application")
' Set objFolders = objOL.Session.Folders
'
' On Error Resume Next
'
' For i = objFolders.Count To 1 Step -1
' Set objFolder = objFolders.Item(i)
'
' If (InStr(1, objFolder.Name, "Mailbox") = 0) And (InStr(1, objFolder.Name, "Public Folders") = 0) And LCase(Trim(PstName)) = LCase(Trim(objFolder.Name)) Then
' objOL.Session.RemoveStore objFolder
'
' RemovePST = True
' Exit Function
' Else
' RemovePST = False
' End If
' Next i
'End Function
Function DetachPST(astrDisplayName As String, OLAPP As Object) As Boolean
''=======================================================================
'' This routine used the received display name to close an existing pst
'' file
'' author :Henry Happ
''=======================================================================
On Error GoTo Proc_Err
Dim objNS As Outlook.Namespace
Dim objFolder As Outlook.Folder
Set objNS = OLAPP.GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(astrDisplayName)
MsgBox objFolder.FolderPath
objNS.RemoveStore objFolder
'' Return success code
DetachPST = True
Proc_Exit:
If Not objFolder Is Nothing Then Set objFolder = Nothing
If Not objNS Is Nothing Then Set objNS = Nothing
Exit Function
Proc_Err:
MsgBox Err.Number & "-" & Err.Description, , "DetachPST"
If InStr(1, Err.Description, "Impossible de trouver le fichier ", vbTextCompare) > 0 Then
Path = Replace(Err.Description, "Impossible de trouver le fichier ", "", , , vbTextCompare)
Dim FSO
Set FSO = CreateObject("Scripting.FileSystemObject")
FSO.CopyFile "c:\Essai\MonPSTVIDE.pst", Path, True
Resume
Stop
DetachPST = False
GoTo Proc_Exit
End Function |
Partager