Anlagen im Kontakt speichern

Zuletzt geändert am 03. April 2013

Wenn Sie eine Reihe von Kontakten aus anderen Anwendungen importieren, so können Sie dabei keine Anlagen mitimportieren.

Um schnell ohne Drag & Drop Aktionen Anlagen in diesen Kontakten zu speichern, können Sie dieses Codebeispiel benutzen. Es ist in der Lage, bis zu 3 Anlagen hinzuzufügen, kann aber auch nach Bedarf erweitert werden.

Zur Verwendung dieses Beispiels beachten Sie bitte die wichtigen Hinweise, sowie den Workshop VBA in Outlook® verwenden. Den Code bitte in ein neues Modul kopieren (Einfügen -> Modul im VBA-Editor).

Ab Outlook® 2000

Option Explicit
 
Public Sub InsertAttachments()
 
    '=====================================================================
    ' Fügt Anlagen zum Notizfeld in Outlook-Kontakten hinzu
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-12-11 Version 1.0.0
    '=====================================================================

    Dim objFolder As Outlook.MAPIFolder
    Dim objItem As Object
    Dim objItems As Outlook.Items
    Dim strAttach1 As String
    Dim strAttach2 As String
    Dim strAttach3 As String
    Dim lngChanged As Long
    Dim blnSave As Boolean
 
    '---------------------------------------------------------------------
    ' Variablen belegen. Soll eine Anlage nicht verwendet werden, dann die
    ' Variable strAttachX auf "" setzen (z. B. strAttach3 = "")
    '---------------------------------------------------------------------
    strAttach1 = "C:\Anlage1.doc"
    strAttach2 = "C:\Anlage2.pdf"
    strAttach3 = "C:\Anlage3.xls"
 
    '---------------------------------------------------------------------
    ' Anlagen (noch) vorhanden?
    '---------------------------------------------------------------------
    If strAttach1 <> "" Then
        If Dir(strAttach1) = "" Then
            MsgBox "Die Anlage """ & strAttach1 & """ ist (mehr) nicht vorhanden." _
                , vbCritical + vbOKOnly, "Anlagen einfügen"
            Exit Sub
        End If
    End If
    If strAttach2 <> "" Then
        If Dir(strAttach2) = "" Then
            MsgBox "Die Anlage """ & strAttach2 & """ ist (mehr) nicht vorhanden." _
                , vbCritical + vbOKOnly, "Anlagen einfügen"
            Exit Sub
        End If
    End If
    If strAttach3 <> "" Then
        If Dir(strAttach3) = "" Then
            MsgBox "Die Anlage """ & strAttach3 & """ ist (mehr) nicht vorhanden." _
                , vbCritical + vbOKOnly, "Anlagen einfügen"
            Exit Sub
        End If
    End If
 
    '---------------------------------------------------------------------
    ' Kontakteordner auswählen
    '---------------------------------------------------------------------
    Set objFolder = ChooseFolder
 
    '---------------------------------------------------------------------
    ' Nichts ausgewählt?
    '---------------------------------------------------------------------
    If objFolder Is Nothing Then Exit Sub
 
    '---------------------------------------------------------------------
    ' Alle Elemente im ausgewählten Ordner referenzieren
    '---------------------------------------------------------------------
    Set objItems = objFolder.Items
 
    '---------------------------------------------------------------------
    ' Alle Kontakte bearbeiten
    '---------------------------------------------------------------------
    For Each objItem In objItems
 
        '-----------------------------------------------------------------
        ' Merker, dass ein Kontakt geändert wurde, zurücksetzen
        '-----------------------------------------------------------------
        blnSave = False
 
        '-----------------------------------------------------------------
        ' Nur Kontakte, keine Verteilerlisten bearbeiten
        '-----------------------------------------------------------------
        If objItem.Class = olContact Then
 
            '-------------------------------------------------------------
            ' Wenn noch nicht vorhanden, dann 1. Anlage hinzufügen
            '-------------------------------------------------------------
            If Not AttachmentExists(objItem, strAttach1) Then
                Call objItem.Attachments.Add(strAttach1)
                blnSave = True
            End If
 
            '-------------------------------------------------------------
            ' 2. Anlage hinzufügen?
            '-------------------------------------------------------------
            If Not AttachmentExists(objItem, strAttach2) Then
                Call objItem.Attachments.Add(strAttach2)
                blnSave = True
            End If
 
            '-------------------------------------------------------------
            ' 3. Anlage hinzufügen?
            '-------------------------------------------------------------
            If Not AttachmentExists(objItem, strAttach3) Then
                Call objItem.Attachments.Add(strAttach3)
                blnSave = True
            End If
 
        End If
 
        '-----------------------------------------------------------------
        ' Kontakt speichern?
        '-----------------------------------------------------------------
        If blnSave Then
            objItem.Save
            lngChanged = lngChanged + 1
        End If
 
    Next
 
    '---------------------------------------------------------------------
    ' Meldung an Benutzer
    '---------------------------------------------------------------------
    MsgBox "Geänderte Kontakte: " & lngChanged, vbInformation, "Anlagen einfügen"
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objItem = Nothing
    Set objItems = Nothing
    Set objFolder = Nothing
 
End Sub
 
Private Function ChooseFolder() As Outlook.MAPIFolder
 
    '=====================================================================
    ' Gibt einen ausgewählten Kontakteordner zurück
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-12-11 Version 1.0.0
    '=====================================================================
 
    Dim objFolder As Object
 
    '---------------------------------------------------------------------
    ' Hinweis anzeigen
    '---------------------------------------------------------------------
    If MsgBox("Bitte wählen Sie im nächsten Dialog einen Kontakteordner aus." _
        , vbInformation + vbOKCancel, "Anlagen einfügen") = vbCancel Then Exit Function
 
    '---------------------------------------------------------------------
    ' Schleife wird solange durchlaufen, bis ein gültiger Ordner ausgewählt
    ' oder die Auswahl abgebrochen wird.
    '---------------------------------------------------------------------
    Do
 
        '-----------------------------------------------------------------
        ' Ordnerauswahl anzeigen
        '-----------------------------------------------------------------
        Set objFolder = Nothing
        Set objFolder = Outlook.Session.PickFolder
 
        '-----------------------------------------------------------------
        ' Wurde die Auswahl abgebrochen?
        '-----------------------------------------------------------------
        If objFolder Is Nothing Then Exit Function
 
        '-----------------------------------------------------------------
        ' Falscher Ordnertyp ausgewählt?
        '-----------------------------------------------------------------
        If InStr(objFolder.DefaultMessageClass, "IPM.Contact") = 0 Then
            Set objFolder = Nothing
            If MsgBox("Bitte wählen Sie einen Ordner für Kontakte aus." _
                , vbCritical + vbOKCancel, "Kontakteordner auswählen") = vbCancel Then
                Exit Function
            End If
        End If
 
    Loop While objFolder Is Nothing
 
    '---------------------------------------------------------------------
    ' Ordner bzw. Nothing zurückgeben
    '---------------------------------------------------------------------
    Set ChooseFolder = objFolder
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objFolder = Nothing
 
End Function
 
Private Function AttachmentExists(ByVal objItem As Object, ByVal strAttach As String) As Boolean
 
    '=====================================================================
    ' Prüft, ob eine Anlage in einem Kontakt schon vorhanden ist
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-12-11 Version 1.0.0
    '=====================================================================
    
    Dim objAttachment As Outlook.Attachment
 
    '---------------------------------------------------------------------
    ' Keine Anlage hinzufügen?
    '---------------------------------------------------------------------
    If Trim(strAttach) = "" Then
        AttachmentExists = True
        GoTo ExitProc
    End If
 
    '---------------------------------------------------------------------
    ' Anlagename von Verzeichnis trennen
    '---------------------------------------------------------------------
    strAttach = GetFileName(strAttach)
 
    '---------------------------------------------------------------------
    ' Alle Anlagen bearbeiten
    '---------------------------------------------------------------------
    For Each objAttachment In objItem.Attachments
        If objAttachment.FileName = strAttach Then
            AttachmentExists = True
            GoTo ExitProc
        End If
    Next
 
ExitProc:
 
    '---------------------------------------------------------------------
    ' Clean Up
    '---------------------------------------------------------------------
    Set objAttachment = Nothing
    Set objItem = Nothing
 
End Function
 
Private Function GetFileName(ByVal strFile As String) As String
 
    '=====================================================================
    ' Schneidet von einer Pfadangabe den Pfad ab und gibt die Datei zurück
    ' (c) Peter Marchert - http://www.outlook-stuff.com
    ' 2008-12-11 Version 1.0.0
    '=====================================================================
    
    Dim lngPos As Long
 
    '---------------------------------------------------------------------
    ' Letzten Backslash von rechts ermitteln
    '---------------------------------------------------------------------
    lngPos = InStrRev(strFile, "\")
 
    '---------------------------------------------------------------------
    ' Wenn gefunden, dann alles rechts davon zurückgeben
    '---------------------------------------------------------------------
    If lngPos <> 0 Then GetFileName = Right(strFile, Len(strFile) - lngPos)
 
End Function