0
Bonjour, J'ai trouvé ce code et je l'utilise depuis un moment maintenant, mais je cherche à ajouter une règle pour enregistrer uniquement les pièces jointes PDF et compter combien de fichiers PDF ont été sauvegardés.Outlook enregistrer uniquement les pièces jointes au format PDF
Je l'ai obtenu en sauvegardant tous les fichiers et il boucle les fichiers dupliqués mais je veux juste qu'il enregistre les fichiers pdf.
Quelqu'un peut-il vous aider s'il vous plaît?
grâce
' ######################################################
' Returns the number of attachements in the selection.
' ######################################################
Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO As Object ' Computer's file system object.
Dim objShell As Object ' Windows Shell application object.
Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
Dim objItem As Object ' A specific member of a Collection object either by position or by key.
Dim selItems As Selection ' A collection of Outlook item objects in a folder.
Dim Atmt As Attachment ' A document or link to a document contained in an Outlook item.
Dim strAtmtPath As String ' The full saving path of the attachment.
Dim strAtmtFullName As String ' The full name of an attachment.
Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
Dim intDotPosition As Integer ' The dot position in an attachment name.
Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
Dim strFolderpath As String ' The selected folder path.
Dim blnIsEnd As Boolean ' End all code execution.
Dim blnIsSave As Boolean ' Consider if it is need to save.
Dim oItem As Object
Dim iAttachments As Integer
blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
On Error Resume Next
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
' Get the handle of Outlook window.
lHwnd = FindWindow(olAppCLSN, vbNullString)
If lHwnd <> 0 Then
' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
' /* Failed to create the Shell application. */
If Err.Number <> 0 Then
MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
Err.Description & ".", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
If objFolder Is Nothing Then
strFolderpath = ""
blnIsEnd = True
GoTo PROC_EXIT
Else
strFolderpath = CGPath(objFolder.Self.Path)
' /* Go through each item in the selection. */
For Each objItem In selItems
lCountEachItem = objItem.Attachments.Count
' /* If the current item contains attachments. */
If lCountEachItem > 0 Then
Set atmts = objItem.Attachments
' /* Go through each attachment in the current item. */
For Each Atmt In atmts
' Get the full name of the current attachment.
strAtmtFullName = Atmt.FileName
' Find the dot postion in atmtFullName.
intDotPosition = InStrRev(strAtmtFullName, ".")
' Get the name.
strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
' Get the file extension.
strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
' Get the full saving path of the current attachment.
strAtmtPath = strFolderpath & Atmt.FileName
' /* If the length of the saving path is not larger than 260 characters.*/
If Len(strAtmtPath) <= MAX_PATH Then
' True: This attachment can be saved.
blnIsSave = True
' /* Loop until getting the file name which does not exist in the folder. */
Do While objFSO.FileExists(strAtmtPath)
strAtmtNameTemp = strAtmtName(0) & _
Format(Now, "_mmddhhmmss") & _
Format(Timer * 1000 Mod 1000, "000")
strAtmtPath = strFolderpath & strAtmtNameTemp & "." & strAtmtName(1)
' /* If the length of the saving path is over 260 characters.*/
If Len(strAtmtPath) > MAX_PATH Then
lCountEachItem = lCountEachItem - 1
' False: This attachment cannot be saved.
blnIsSave = False
Exit Do
End If
Loop
' /* Save the current attachment if it is a valid file name. */
If blnIsSave Then Atmt.SaveAsFile strAtmtPath
Else
lCountEachItem = lCountEachItem - 1
End If
Next
End If
' Count the number of attachments in all Outlook items.
lCountAllItems = lCountAllItems + lCountEachItem
Next
End If
Else
MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
' /* For run-time error:
' The Explorer has been closed and cannot be used for further operations.
' Review your code and restart Outlook. */
Else
MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
' /* Release memory. */
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (Atmt Is Nothing) Then Set Atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing
' /* End all code execution if the value of blnIsEnd is True. */
If blnIsEnd Then End
End Function
' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function
' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
Dim oItem As Object
Dim iAttachments As Integer
For Each oItem In ActiveExplorer.Selection
iAttachments = oItem.Attachments.Count + iAttachments
Next
MsgBox "Selected " & ActiveExplorer.Selection.Count & " messages with " & iAttachments & " attachements"
End Sub
Oh !! man ... j'ai besoin de rafraichir ma page plus souvent lol – 0m3r
merci c'est maintenant seulement de sauvegarder des fichiers PDF ce qui est super mais ça ne les sauve pas tous il me semble en manquer. J'essaye de sauver d'environ 500 email avec environ 509 pièces jointes de pdf mais c'est seulement le téléchargement autour de 250 –
résolu il j'avais laissé quelque code que j'essayais dedans et c'était contradictoire. Merci beaucoup pour votre aide R3uK –