Mailanhänge aus Lotus Notes in Ordner ablegen

Guten Abend Excelaner
Ich muss aus einem Postfach in Lotus Notes alle E-Mails auslesen und die Dateianhänge (*.jpg) in Ordner im Pfad "C:/images/" ablegen. Der Ordner muss aus der ersten Zahl des Betreffs der jeweiligen E-Mail bestehen.
Dazu habe ich hier einiges an Code gefunden, der macht aber natürlich nicht das was ich benötige:


https://dbwiki.net/wiki/VBA_Tipp:_E-Mails_mit_Attachments_aus_Notes_auslesen

Hier noch einige Anforderungen:
- Der Betreff jeder E-Mail hat das Format 12345678 (123456). Der Ordner, in dem die Fotos aus dieser E-Mail abgelegt werden sollen, muss in diesem Fall "12345678" heissen (Kann auch das Zeichen "-" enthalten).
- Es gibt E-Mails ohne Fotos und E-Mails mit mehreren Fotos. Es kann auch mehrere E-Mails mit dem gleichen Betreff und/oder der gleichen Zahl am Anfang geben. Somit kann es vorkommen, dass der zu erstellende Ordner bereits existiert.
- Die Fotos sollen unter dem Namen im jeweiligen Ordner gepseichert werden, den sie auch in der E-Mail haben (z.B.: "IMG_2319.jpg").
Ich habe den Code mal in eine Excel Datei kopiert und "Mailfile" und "Server" hinzugefügt sowie einige Korrekturen vorgenommen.
Vielen vielen Dank im Voraus, schönen Abend & Gruss
Henner


https://www.herber.de/bbs/user/112555.xlsm _
a>

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Const myServer As String = "HIER SERVER EINTRAGEN" Const myMailfile As String = "HIER MAILFILE EINTRAGEN" Public Function NotesEMailsAnzeigen() As Integer On Error GoTo ErrBeh Dim intErgebnis As Integer Dim objNotes As Object Dim LNdb As Object Dim LNView As Object Dim LNDoc As Object Dim LNItem As Object Dim strSubject As String Dim LNWorkspace As Object Dim LNAttachment As Variant intErgebnis = 0 Set objNotes = GetObject("", "Notes.NotesSession") Set LNdb = objNotes.GETDATABASE(myServer, myMailfile) Set LNWorkspace = CreateObject("notes.notesuiworkspace") LNWorkspace.OpenDatabase myServer, myMailfile If Not (LNdb Is Nothing) Then Set LNView = LNdb.GETVIEW("$Inbox") If Not (LNView Is Nothing) Then Call LNView.Refresh Set LNDoc = LNView.GETFIRSTDOCUMENT Do While Not LNDoc Is Nothing Set LNItem = LNDoc.GETFIRSTITEM("Subject") Debug.Print LNItem.Text Select Case MsgBox("Soll die Mail mit dem Subject: " + vbNewLine + vbNewLine + _ LNItem.Text + vbNewLine + " angezeigt werden?", vbYesNo) Case vbYes LNWorkspace.EDITDOCUMENT True, LNDoc, False, "", True, True End Select Set LNItem = LNDoc.GETFIRSTITEM("Body") Debug.Print LNItem.Text If LNDoc.HasEmbedded Then Debug.Print vbNewLine + "Attached Files:" For Each LNAttachment In LNItem.EmbeddedObjects Debug.Print LNAttachment.Name Select Case MsgBox("Attachment: " & _ LNAttachment.Name & _ " nach C:\ extrahieren?", vbYesNo) Case vbYes LNAttachment.ExtractFile ("C:\" + LNAttachment.Name) End Select Next Debug.Print vbNewLine End If Set LNDoc = LNView.GETNEXTDOCUMENT(LNDoc) Loop End If End If GoTo Ende ErrBeh: Err.Clear intErgebnis = 1 Ende: Set objNotes = Nothing Set LNdb = Nothing Set LNView = Nothing Set LNItem = Nothing Set LNWorkspace = Nothing Set LNDoc = Nothing NotesEMailsAnzeigen = intErgebnis End Function

Const myServer As String = "LNT04110/SRV/DACH041/DACHSER/DE" Const myMailfile As String = "mail\ssoellne.nsf" Const savePath As String = "D:\" Public Function NotesEMailsAnzeigen() As Integer On Error GoTo ErrBeh Dim filePath As String Dim intErgebnis As Integer Dim objNotes As Object Dim LNdb As Object Dim LNView As Object Dim LNDoc As Object Dim LNItem As Object Dim strSubject As String Dim LNWorkspace As Object Dim LNAttachment As Variant intErgebnis = 0 Set objNotes = GetObject("", "Notes.NotesSession") Set LNdb = objNotes.GETDATABASE(myServer, myMailfile) Set LNWorkspace = CreateObject("notes.notesuiworkspace") LNWorkspace.OpenDatabase myServer, myMailfile If Not (LNdb Is Nothing) Then Set LNView = LNdb.GETVIEW("$Inbox") If Not (LNView Is Nothing) Then Call LNView.Refresh Set LNDoc = LNView.GETFIRSTDOCUMENT Do While Not LNDoc Is Nothing Set LNItem = LNDoc.GETFIRSTITEM("Subject") On Error Resume Next filePath = Trim(Left(LNItem.Text, InStr(1, LNItem.Text, " ", vbTextCompare)) _ ) Debug.Print filePath MkDir savePath MkDir savePath & "\" & filePath On Error GoTo 0 Debug.Print LNItem.Text Set LNItem = LNDoc.GETFIRSTITEM("Body") If LNDoc.HasEmbedded Then For Each LNAttachment In LNItem.EmbeddedObjects Debug.Print LNAttachment.Name LNAttachment.ExtractFile (savePath + "\" + filePath + "\" + _ LNAttachment.Name) Next End If Set LNDoc = LNView.GETNEXTDOCUMENT(LNDoc) Loop End If End If GoTo Ende ErrBeh: Err.Clear intErgebnis = 1 Ende: Set objNotes = Nothing Set LNdb = Nothing Set LNView = Nothing Set LNItem = Nothing Set LNWorkspace = Nothing Set LNDoc = Nothing NotesEMailsAnzeigen = intErgebnis End Function

Ich nochmal...
Ich habe den Code jetzt soweit umbauen können, dass nur Fotos abgelegt werden die in ihrem Dateinamen "Q3" oder "Q4" enthalten und auch nur ein Ordner angelegt wird wenn auch Fotos abgelegt werden. Die UserForm mit dem Counter ist auch schon drin, da fehlt mir allerdings jetzt noch der Zielwert (Gesamt Anzahl E-Mails im Postfach).
Wäre super wenn Du mir die Zeile noch verraten würdest. DANKE! Gruss Henner


Public Function NotesEMailsAnzeigen() As Integer
On Error GoTo ErrBeh
Dim filePath As String
Dim intErgebnis As Integer
Dim objNotes As Object
Dim LNdb As Object
Dim LNView As Object
Dim LNDoc As Object
Dim LNItem As Object
Dim strSubject As String
Dim LNWorkspace As Object
Dim LNAttachment As Variant
Dim savePath As String
Dim myMailfile As String
Dim myServer As String
savePath = ThisWorkbook.Path & "\img2\"
myServer = "CHSDBNN12/SCH"
myMailfile = "MAIL/SCH/mailin/quickche.nsf"
intErgebnis = 0
Set objNotes = GetObject("", "Notes.NotesSession")
Set LNdb = objNotes.GETDATABASE(myServer, myMailfile)
Set LNWorkspace = CreateObject("notes.notesuiworkspace")
LNWorkspace.OpenDatabase myServer, myMailfile
UserForm1.Show vbModeless
UserForm1.Label1.Caption = 1
If Not (LNdb Is Nothing) Then
Set LNView = LNdb.GETVIEW("$Inbox")
If Not (LNView Is Nothing) Then
Call LNView.Refresh
Set LNDoc = LNView.GETFIRSTDOCUMENT
Do While Not LNDoc Is Nothing
Set LNItem = LNDoc.GETFIRSTITEM("Subject")
On Error GoTo 0
Debug.Print LNItem.Text
Set LNItem = LNDoc.GETFIRSTITEM("Body")
If LNDoc.HasEmbedded Then
For Each LNAttachment In LNItem.EmbeddedObjects
Debug.Print LNAttachment.Name
If InStr(LNAttachment.Name, "Q3") > 0 = True Or InStr(LNAttachment.Name, _
"Q4") > 0 = True Then
Set LNItem = LNDoc.GETFIRSTITEM("Subject")
On Error Resume Next
filePath = Trim(Left(LNItem.Text, InStr(1, LNItem.Text, " ",  _
vbTextCompare)))
Debug.Print filePath
MkDir savePath
MkDir savePath & "\" & filePath
LNAttachment.ExtractFile (savePath & "\" & filePath + "\" &  _
LNAttachment.Name)
End If
UserForm1.Label1.Caption = UserForm1.Label1.Caption + 1
DoEvents
Next
End If
Set LNDoc = LNView.GETNEXTDOCUMENT(LNDoc)
Loop
End If
End If
Unload UserForm1
GoTo Ende
ErrBeh:
Err.Clear
intErgebnis = 1
Ende:
Set objNotes = Nothing
Set LNdb = Nothing
Set LNView = Nothing
Set LNItem = Nothing
Set LNWorkspace = Nothing
Set LNDoc = Nothing
NotesEMailsAnzeigen = intErgebnis
End Function

Beliebteste Forumthreads (12 Monate)

Mailanhänge aus Lotus Notes in Ordner ablegen

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Mailanhänge aus Lotus Notes in Ordner ablegen

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

301 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread