Anhänge aus Mail löschen und in Mail vermerken

Moderator: ModerationP

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon mumpel » 04. Feb 2019, 21:38

Solange es keine Bildformate (jpg, png, tiff etc. pp.) sind kannst Du folgenden Code versuchen.

Code: Alles auswählen

Sub SaveAttachment()
 
    Dim myAttachments     As Outlook.Attachments
    Dim olMailItem        As Outlook.MailItem
    Dim lngAttachCount    As Long
    Dim strAttach         As String

    ' Aktive Mail setzen
    Select Case True
           Case TypeOf Application.ActiveWindow Is Outlook.Inspector
                Set olMailItem = Application.ActiveInspector.CurrentItem
           Case Else
                With Application.ActiveExplorer.Selection
                     If .Count Then Set olMailItem = .Item(1)
                End With
                If olMailItem Is Nothing Then Exit Sub
           End Select
     
       ' Anhangobjekt erstellen
        Set myAttachments = olMailItem.Attachments
       
        ' Anhänge prüfen und löschen. Nur Dateien der Typen PDF, ZIP und XLSB werden gelöscht
        If myAttachments.Count > 0 Then
         
                For lngAttachCount = myAttachments.Count To 1 Step -1
                    If Right(myAttachments(lngAttachCount).DisplayName, 3) = "pdf" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "xlsm" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "xlsb" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "xlsx" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "docm" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "docx" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "dotx" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 4) = "dotm" Or _
                       Right(myAttachments(lngAttachCount).DisplayName, 3) = "xls" Then
                           strAttach = strAttach & vbCrLf & myAttachments(lngAttachCount).DisplayName
                           myAttachments(lngAttachCount).Delete
                    End If
                Next lngAttachCount
 
            ' Anhang-Namen in Textdatei schreiben, Textdatei als Anhang setzen
            Open Environ("USERPROFILE") & "\Desktop\geloeschte_dateien.txt" For Output As #1
                 Print #1, strAttach
                 Close #1
                 olMailItem.Attachments.Add Environ("USERPROFILE") & "\Desktop\geloeschte_dateien.txt"
        End If
       
' Textdatei von Festplatte löschen
Kill Environ("USERPROFILE") & "\Desktop\geloeschte_dateien.txt"

End Sub
Benutzeravatar
mumpel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8043
Registriert: 09. Jan 2005, 15:20
Wohnort: Lindau (B)

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon mumpel » 04. Feb 2019, 22:14

Allerdings werden im Beispielcode die Dateien nur gelöscht. Das vorherige Speichern auf dem Server bekommst Du hin? Wenn die Dateien anklickbar sein sollten kannst Du sie in einen Link packen und die Datei als html-Datei speichern und anhängen anstatt einer Textdatei.
Benutzeravatar
mumpel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8043
Registriert: 09. Jan 2005, 15:20
Wohnort: Lindau (B)

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon OLLI_S » 07. Feb 2019, 21:34

Hallo mumpel,

das VBA ist klasse, ich muss es nur noch etwas verfeinern.
Beispielsweise PowerPoint-Dateien mit aufnehmen, Prüfen, ob Anlagen vorhanden sind, in der Textdatei eine Überschrift und eine Summenzeile einbauen, etc.
Aber tausend Dank, dein VBA hilft wirklich sehr und ist eine super Lösung.

Das Speichern auf dem Server mache ich im ersten Schritt mal nicht, aber das steht ja in dem alten VBA (http://www.outlookcode.com/codedetail.aspx?id=70):
Code: Alles auswählen
myAttachments(i).SaveAsFile myOrt & myAttachments(i).DisplayName

Also sollte ich das hinbekommen.

Eine Frage habe ich aber noch:
Ich gebe jetzt auch die Dateigröße des Anhangs hinter dem Namen mit aus (über myAttachments(lngAttachCount).Size).
Die Dateigröße ist in Bytes, hier möchte ich Tausenderpunkte mit ausgeben.
Also anstelle "1234567 Bytes" möchte ich "1.234.567 Bytes" ausgeben.
Und eventuell wandle ich das ganze noch in KB um (teilen durch 1024).

Bielen Dank!

Gruß

OLLI
OLLI_S
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 131
Registriert: 14. Mai 2005, 10:34

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon mumpel » 07. Feb 2019, 23:52

Auf Anlagen geprüft wird in meinem Code mit If myAttachments.Count > 0 Then.
Benutzeravatar
mumpel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8043
Registriert: 09. Jan 2005, 15:20
Wohnort: Lindau (B)

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon OLLI_S » 08. Feb 2019, 15:05

Hallo mumpel,

mumpel hat geschrieben:Auf Anlagen geprüft wird in meinem Code mit If myAttachments.Count > 0 Then.


Stimmt, hatte mir das nur aufgeschrieben, dass ich das nicht vergesse.
Inzwischen habe ich es auch hinbekommen, dass die Dateigröße mit Tausenderpunkte ausgegeben wird.
Perfekt.

Ich weiß allerdings nicht, wie ich einen "Ordner-Auswahl" Dialog anzeigen lassen kann.
Dazu habe ich folgenden Code gefunden, der in Excel perfekt funktioniert, aber nicht in Outlook:
Code: Alles auswählen
Dim strPath As String
With Application.FileDialog(msoFileDialogFolderPicker)
    .AllowMultiSelect = False
    .InitialFileName = "L:\"
    .Title = "Bitte Ordner für den Export des Projekts auswhählen!"
    .ButtonName = "Auswählen"
    .Show
    If .SelectedItems.Count > 0 Then
        strPath = .SelectedItems(1)
    End If
End With


Was muss ich machen, damit ich in Outlook 2010 auch einen Ordner-Auswahl Dialog bekomme?
Vielen Dank!

Gruß

OLLI
OLLI_S
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 131
Registriert: 14. Mai 2005, 10:34

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon mumpel » 08. Feb 2019, 17:39

Ungetestet:
Code: Alles auswählen
Option Explicit
' For Outlook 2010.
#If VBA7 Then
    ' The window handle of Outlook.
    Private lHwnd As LongPtr

    ' /* API declarations. */
    Private Declare PtrSafe Function FindWindow Lib "user32" _
            Alias "FindWindowA" (ByVal lpClassName As String, _
                                 ByVal lpWindowName As String) As LongPtr

' For the previous version of Outlook 2010.
#Else
    ' The window handle of Outlook.
    Private lHwnd As Long

    ' /* API declarations. */
    Private Declare Function FindWindow Lib "user32" _
            Alias "FindWindowA" (ByVal lpClassName As String, _
                                 ByVal lpWindowName As String) As Long
#End If
'
' Windows desktop -
' the virtual folder that is the root of the namespace.
Private Const CSIDL_DESKTOP = &H0

' Only return file system directories.
' If user selects folders that are not part of the file system,
' then OK button is grayed.
Private Const BIF_RETURNONLYFSDIRS = &H1

' Do not include network folders below
' the domain level in the dialog box's tree view control.
Private Const BIF_DONTGOBELOWDOMAIN = &H2

Public Sub SelectFolder()
    Dim objFSO As Object
    Dim objShell As Object
    Dim objFolder As Object
    Dim strFolderPath As String
    Dim blnIsEnd As Boolean

    blnIsEnd = False

    Set objShell = CreateObject("Shell.Application")
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objShell.BrowseForFolder( _
                lHwnd, "Please Select Folder to:", _
                BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)


    If objFolder Is Nothing Then
        strFolderPath = ""
        blnIsEnd = True
        GoTo PROC_EXIT
    Else
        strFolderPath = CGPath(objFolder.Self.Path)
    End If

PROC_EXIT:
    Set objFSO = Nothing
    If blnIsEnd Then End
End Sub

Public Function CGPath(ByVal Path As String) As String
    If Right(Path, 1) <> "\" Then Path = Path & "\"
    CGPath = Path
End Function

Quelle (gleich das erste Ergebnis in der Google-Suche :wink: ): https://stackoverflow.com/questions/439 ... -not-found
Benutzeravatar
mumpel
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 8043
Registriert: 09. Jan 2005, 15:20
Wohnort: Lindau (B)

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon halweg » 11. Feb 2019, 12:01

Ich kenne das Problem und behandle es seit Jahren mit folgendem Makro:
Code: Alles auswählen
Sub Dateianlagen_loeschen_eine_Mail(akt_mail As MailItem)
' Das Einfügen des Anlagentextes funktioniert nur, wenn ein tag <body> ohne <body ...> enthalten ist.
Dim mailanhang As Attachment, anlagenliste As String, body_pos As Long, body_start As String
 
  If akt_mail.Attachments.Count < 1 Then Beenden ("Kein E-Mail-Anhang gefunden")
  If akt_mail.BodyFormat = olFormatHTML Then
    anlagenliste = "<font face=""Arial""><i>Entfernte Dateianhänge: " & "<br><font color=""#0000FF"">"
    For i = 1 To akt_mail.Attachments.Count
      anlagenliste = anlagenliste & akt_mail.Attachments.item(1).FileName & " (Größe: " & Round(akt_mail.Attachments.item(1).Size / 1000000, 2) & " MByte) <br>"
      akt_mail.Attachments.item(1).Delete  ' nach dem Löschen wird die nächste Anlage item(1), deshalb keine Verwendung von item(i)
    Next i
    anlagenliste = anlagenliste & "</font></i>"
    body_pos = InStr(akt_mail.HTMLBody, "<body")
    If Not body_pos > 0 Then
      Beenden ("Konnte in der E-Mail keinen body-Tag finden")
    Else
      body_start = Mid(akt_mail.HTMLBody, 1, body_pos - 1) ' wir merken uns den Teil vom HTML-Text, der bis vor den < in <body geht
      [color=#0000FF]akt_mail.HTMLBody = body_start & Replace(akt_mail.HTMLBody, ">", ">" & anlagenliste, body_pos, 1)[/color]
    End If
  Else
    anlagenliste = "Entfernte Dateianhänge: " & vbLf
    For i = 1 To akt_mail.Attachments.Count
      anlagenliste = anlagenliste & akt_mail.Attachments.item(1).FileName & " (Größe: " & Round(akt_mail.Attachments.item(1).Size / 1000000, 2) & " MByte)   " & vbLf
      akt_mail.Attachments.item(1).Delete
    Next i
    [color=#0000FF]akt_mail.Body = anlagenliste & akt_mail.Body[/color]
  End If
End Sub

An den Anfang der Mail wird also die Liste der gelöschten Anlagen, jeweils mit deren Größe, geschrieben, bei HTML-Format auch farblich hervorgehoben und mit den nötigen HTML-Tags versehen. Das ist dann immer gut zu erkennen.
Vielleicht kannst du ja daraus noch Ideen oder Codeelemente für deine Vorgehensweise ableiten.

Das Speichern von gelöschten Anlagen halte ich für de falschen Schritt. Es ist zwar ein beruhigendes Gefühl, aber (1) sollte eine Mail-Anlage, wenn sie irgendeine Bedeutung hat, direkt im Zusammenhang mit dem Maileingang abgespeichert werden (im Projektverzeichnis oder wo auch immer sie hingehört) und (2) könnte man, ein ordentliches Backupmanagement vorausgesetzt, die Anhänge immer noch aus der jeweiligen Sicherungskopie herausextrahieren.
Bei mir werden grundsätzlich nur Anhänge von Mails, die "älter ein Jahr" und "größer 1 MB" sind entfernt, dafür habe ich dann einen extra Filter. Mit diesem Verfahren halte ich meine outlook.pst seit Jahren unter 2 GB.

Viele Grüße, Halweg
Office 2002, 2010; Windows 7, 10
Benutzeravatar
halweg
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 470
Registriert: 21. Okt 2010, 08:04
Wohnort: Dresden

Re: Anhänge aus Mail löschen und in Mail vermerken

Beitragvon Bliquedicht » 14. Mär 2019, 12:27

Hallo Zusammen,

Ich bin über die im Thema genannte Problematik auf folgenden alten Beitrag gestoßen:
http://www.office-loesung.de/ftopic503582_0_0_asc.php

Der Beitrag würde nach dem kurzen Querlesen all das machen was ich mir vorstelle, also:
- Anhang abspeichern (mit Pfadauswahl)
- Link in der Mail erzeugen
- Anhang löschen
Angeblich soll das ganze auch mit mehreren Anhängen funktionieren.

Leider ist die finale Version nicht mehr herunterladbar. Weiß jemand wie ich an diese Datei oder den Quelltext komme?

Danke
Bliquedicht
Neuling
 
Beiträge: 1
Registriert: 14. Mär 2019, 10:32

Vorherige

Zurück zu Outlook Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 1 Gast