Anlagen im Kontakt speichern
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