Microsoft Outlook troubleshooting
Zapis załączników z wszystkich zaznaczonych elementów na dysk

Zapis załączników z wszystkich zaznaczonych elementów na dysk

autor CodeTwo 2006-06-06 00:00:00 w Makra

Artykuł dotyczy: Microsoft Outlook 2000/2002/2003

Poniższe makro zapisuje załączniki z wszystkich zaznaczonych elementów na dysku. Zmienna strDestFolderPath (*1) określa docelowy katalog na dysku, makro tworzy w nim podkatalog o takiej samej nazwie jak folder w Outlook'u, w którym znajdują się zaznaczone elementy (*3). Następnie przetwarzane są wszystkie zaznaczone elementy, mogą to być elementy dowolnego typu - nie tylko wiadomości pocztowe. Na dysk zapisywane są wszystkie załączniki typu olByValue (pliki) i olEmbeddeditem (inne elementy Outlook'a) (*4). Załączniki typu olOLE (osadzone obiekty OLE) nie mogą zostać zapisane na dysk przy użyciu funkcji API Outlook'a, natomiast typ olByReference (odnośniki do plików) nie jest już używany.

Jeśli wartość zmiennej bDeleteAttach (*2) jest ustawiona na True, to wszystkie zapisane załączniki zostaną usunięte z oryginalnego elementu (*5). Do usuwania załączników nie została użyta funkcja Attachments::Remove ponieważ nie działa ona w programie Outlook 2000.

Po przetworzeniu elementu, jest on odpowiednio oznaczany, aby nie był przetwarzany ponownie przy następnym uruchomieniu makra (*6).

Sub SaveAttachments()
    On Error Resume Next

    ' (*1) Ścieżka do głownego foldera gdzie mają być zapisywane załączniki
    Dim strDestFolderPath
    strDestFolderPath = "C:\temp\attachments\"
    
    ' (*2) Jeśli chcesz usuwać zapisane załączniki, zmień wartość tej zmiennej na True
    Const bDeleteAttach = False
    
    
    ' (*3) Utwórz nowy folder o takiej samej nazwie jak folder w Outlook'u
    Set fso = CreateObject("Scripting.FileSystemObject")
    fso.CreateFolder strDestFolderPath
    
    Dim oFolder As MAPIFolder
    Set oFolder = Application.ActiveExplorer.CurrentFolder
    
    strDestFolderPath = strDestFolderPath & oFolder.Name & "\"
    fso.CreateFolder strDestFolderPath
    
    
    ' Przetwarzaj wszystkie elementy w tym folderze
    For Each Item In Application.ActiveExplorer.Selection
    
        If Item.Attachments.Count > 0 And Item.UserProperties.Item("processed").Value <> 1 Then
            
            ' Tu będziemy zapamiętywać indeksy zapisanych załączników, żeby potem wiedzieć
            ' które usuwać
            ReDim arAttachIndexes(0) As Integer
            
            ' Zapisz wszystkie załączniki
            For Each attach In Item.Attachments
                Dim oAttach As Attachment
                Set oAttach = attach
                
                ' (*4)
                If oAttach.Type = olByValue Or oAttach.Type = olEmbeddeditem Then
                    
                    oAttach.SaveAsFile strDestFolderPath & oAttach.FileName
                    
                    ' Zapamiętaj index załącznika
                    ReDim Preserve arAttachIndexes(UBound(arAttachIndexes) + 1)
                    arAttachIndexes(UBound(arAttachIndexes)) = oAttach.Index
                End If
            Next
            
            If Not IsEmpty(arAttachIndexes) Then
            
                If bDeleteAttach Then
                    ' (*5) Usuń wszystkie zapisane wcześniej załączniki
                    For Index = UBound(arAttachIndexes) To 1 Step -1
                        Dim att: Set att = Item.Attachments(arAttachIndexes(Index))
                        att.Delete
                    Next
                End If
                
            End If
            
            ' (*6) Oznacz jako przetworzony
            Item.UserProperties.Add "processed", olNumber
            Item.UserProperties.Item("processed").Value = 1
            Item.Save
            
        End If
        
    Next

End Sub

Jeśli masz jakieś pytania lub komentarze dotyczące tego artykułu, napisz na naszym forum.

(c) CodeTwo. Wszelkie prawa zastrzeżone.



© Wszelkie prawa zastrzeżone. Żadna część ani całość tego artykułu nie może być powielana ani publikowana bez zgody autora.