Hallo zusammen,
ich verwende den folgenden Code, um E-Mails aus Outlook in eine Datenbank zu übertragen. Derrzeit muss ich nach der Erfassung noch jede Mail mit ihren Anlagen ausdrucken. Das möchte ich gerne automatisieren.
Also, es muss erst die Mail ausgedruckt werden und dann die jeweilige Anlage.
Hat jemand eine Idee wie ich das in diesem Code unterbringen kann?
Ich danke euch vorab schon für eure Mühe.
Florian-BGL
Private Sub Mails_ablegen_Click()
On Error GoTo fehler
Dim intGes As Integer
Dim intz As Integer
Dim inty As Integer
Dim Conn As New ADODB.Connection
Dim DBS As ADODB.Recordset
Dim Conn2 As New ADODB.Connection
Dim DBS2 As ADODB.Recordset
Dim OutMail As Object
Dim intAnhZ As Integer
Dim OutMapi As New Outlook.Application
Dim OutVerz As Object
Dim intV As Integer
Dim intAnhZ2 As Integer
Dim Nummer As Long
Dim Intaz As String
Dim IntMsg As String
Dim Out As Outlook.MAPIFolder
Dim Conn4 As New ADODB.Connection
Dim DBS4 As ADODB.Recordset
Dim Str__Eingabe_Betreff As Integer
On Error GoTo fehler
DoCmd.GoToRecord , , acLast
Set Conn = CurrentProject.Connection
Set Conn2 = CurrentProject.Connection
Set DBS = New ADODB.Recordset
Set DBS2 = New ADODB.Recordset
'Festlegen des Strings für den Pfad wo Anlagen der Mails abgelegt werden sollen
Set Conn4 = CurrentProject.Connection
Set DBS4 = New ADODB.Recordset
DBS4.Open "Tab_Anlagenpfad", Conn4, adOpenKeyset, adLockOptimistic
DBS4.MoveFirst
Str_Anlagenpfad = DBS4!Ablage_Anlagen
DBS4.Close
Set Out = GetObject("", "Outlook.Application").GetNamespace("MAPI").PickFolder()
Set Conn = CurrentProject.Connection
Nummer = 1
DBS2.Open "tab_Anlage", Conn, adOpenKeyset, adLockOptimistic
DBS.Open "Tab_Postbuch", Conn, adOpenKeyset, adLockOptimistic
intGes = Out.Items.Count
intz = 0
inty = ID
For intz = intGes To 1 Step -1
With Out.Items(intz)
inty = inty + 1
'Testeingabe
Str_Mailbetreff = .Subject
Str_Mailinhalt = .Body
If Len(Str_Mailbetreff) < 100 Then GoTo Erfassen Else
Betreffeingabe:
Str_Eingabe_Betreff = InputBox("Bitte die folgende Betreffzeile auf 100 Zeichen einkürzen." & vbCrLf & Str_Mailbetreff & vbCrLf)
If Len(Str__Eingabe_Betreff) > 100 Then GoTo Betreffeingabe Else
.Body = "Ursprüngliche Betreffzeile:" & vbCrLf & Str_Mailbetreff & vbCrLf & .Body
.Save
Str_Mailbetreff = Str_Eingabe_Betreff
Erfassen:
If Str_Eingabe_Aktenzeichen = True Then DoCmd.OpenForm "Frm_Eingabe_Aktenzeichen", , , , , acDialog Else
DBS.AddNew
.Subject = "PB " & inty & " " & Format(.ReceivedTime, "yyyy-mm-dd") & " " & Str_Mailbetreff
.Save
DBS!Titel = .Subject
DBS!Erfassungsdatum = Date
DBS!Erfasser = "A-" & fOSUserName()
DBS!Absender = .SenderName
DBS!Kopie_Empfänger = .CC
DBS!Blindkopie_Empfänger = .BCC
DBS!Empfänger = .To
DBS!Wichtigkeit = .Importance
DBS!Inhalt = .Body
DBS!Oberbegriff = Str_Oberbegriff
DBS!Erhalten_Datum = Format(.ReceivedTime, "dd.mm.yyyy")
DBS!Erhalten_Zeit = Format(.ReceivedTime, "hh:mm")
DBS!Erstellt_am = Format(.CreationTime, "dd.mm.yyyy hh:mm")
DBS!Gesendet = Format(.SentOn, "dd.mm.yyyy hh:mm")
DBS!Letzte_Bearbeitung = Format(.LastModificationTime, "dd.mm.yyyy hh:mm")
DBS!Übertragung = Format(.DeferredDeliveryTime, "dd.mm.yyyy hh:mm")
DBS!Anhang = .Attachments.Count
DBS!BANr = Str_BANr
DBS!Aktenzeichen = Str_Aktenzeichen
DBS!Oberbegriff = Str_Oberbegriff
DBS!Größe = .Size
If Not .UnRead = -1 Then
DBS!Gelesen = "JA"
Else
DBS!Gelesen = "Nein"
End If
DBS.Update
End With
Set OutMail = Out.Items(intz)
If OutMail.Attachments.Count > 0 Then
For intAnhZ2 = 1 To OutMail.Attachments.Count
If OutMail.Attachments.Item(intAnhZ2).Type = "5" Then
Ext = ".msg"
Else
Ext = ""
End If
If Str_Anlagen_speichern = False Then GoTo Anlagen_ohne_speichern_in_DB Else
OutMail.Attachments.Item(intAnhZ2).SaveAsFile Str_Anlagenpfad & "PB " & inty & " " & "(" & Nummer & ")" & Austausch(OutMail.Attachments.Item(intAnhZ2)) & Ext
Anlagen_ohne_speichern_in_DB:
If Str_Anlagen_in_DB = False Then GoTo Anlage_Zusatzablage Else
DBS2.AddNew
DBS2!Anlage = "PB " & inty & " " & "(" & Nummer & ")" & Austausch(OutMail.Attachments.Item(intAnhZ2)) & Ext
DBS2!Anlagendatei.Value = FileToArray(Str_Anlagenpfad & DBS2!Anlage)
DBS2!Datum = Date
DBS2!Betreff = DBS!Titel
DBS2.Update
Anlage_Zusatzablage:
If Str_Anlagen_Zusatzablage = False Then GoTo Ohne_Zusatzspeichern_der_Anlage Else
IntMsg = MsgBox("Möchten Sie die Anlage > " & Austausch(OutMail.Attachments.Item(intAnhZ2)) & Ext & " < zusätzlich in einem weiteren Verzeichnis ablegen?", vbYesNo)
' 6 ist ja; 7 ist nein
If IntMsg = 7 Then GoTo Ohne_Zusatzspeichern_der_Anlage Else
Mailablage:
Const msoFileDialogFolderPicker = 4
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Wählen Sie das Verzeichnis wo die Anlage zusätzlich abgelegt werden soll!"
.InitialFileName = StammOrdner
.AllowMultiSelect = False
If .Show Then
OrdnerDlg = .SelectedItems(1)
MsgBox OrdnerDlg
Str_Anlagen_Pfad = OrdnerDlg & "\" & "PB " & inty & " " & "(" & Nummer & ") " & Austausch(OutMail.Attachments.Item(intAnhZ2)) & Ext
End If
End With
OutMail.Attachments.Item(intAnhZ2).SaveAsFile Str_Anlagen_Pfad
If Str_Anlage_Zusatzablage_mehrfach = False Then GoTo Ohne_Zusatzspeichern_der_Anlage Else
IntMsg = MsgBox("Möchten Sie die Anlage > " & Austausch(OutMail.Attachments.Item(intAnhZ2)) & Ext & " < zusätzlich in einem weiteren Verzeichnis ablegen?", vbYesNo)
If IntMsg = 6 Then GoTo Mailablage Else
Ohne_Zusatzspeichern_der_Anlage:
Nummer = Nummer + 1
Next intAnhZ2
Nummer = 1
End If
Set OutMail = Nothing
Rem Neu:
Next intz
DBS.Close
With DBS
.CursorLocation = adUseClient
.Open "Tab_Postbuch", Conn, adOpenKeyset, adLockOptimistic
.Sort = "Erhalten_Datum ASC"
End With
Set DBS = Nothing
Set Conn = Nothing
MsgBox "Verarbeitung beendet!"
DoCmd.Close
DoCmd.OpenForm "Frm_Hauptübersicht"
Exit Sub
fehler:
MsgBox Err.Number & " " & Err.Description
End Sub
Hallo,
wenn ich richtig sehe, speicherst Du die Anlage(n) als Datei ( "Str_Anlagen_Pfad") ab. Damit ist der Dateiname bekannt und könnte mit z. B. Shellexecute ausgedruckt werden.
Hallo DF6GL,
ja das ist richtig, die Anlagen werden auch als Datei abgelegt. An Shellexecute habe ich gar nicht gedacht. Machmal sitz man aber auch auf der Lösung. Problematischer ist aber der Ausdruck der Mail selbst. Hast du hier auch eine Lösung?
Danke Florian-BGL
Hallo,
lt. Objektkatalog gibt es die MailItem.Printout-Methode....
Hallo,
hast du einen Tip für mich was die Syntax zum MailItem.Printout angeht? Ich habe nicht dazu gefunden.
Das mit der shell execute funktioniert. hier habe ich nur das Problem, das jeweils nur ein PDF gedruckt wird und erst nach dem manuellen Schließen des Fensters die nächste...
Hier werde ich wohl mit einen Automatismus den Acobat-Reader schließen müssen. Unser Firmennetzwerk wird sich wohl nicht auf einen anderen Reader umstellen. >:(
Bei TIF Dateien (so bekomme ich PC-Fax Meldungen) muss ich ebenfalls von Hand drucken. Diese werden mit der Windows Fax Anzeige geöffnet. Auch hier habe ich noch keine Lösung.
Wenn ihr was passendes hierzu habt....
Ich wäre dankbar. das erspart mir viel Sucherei am Wochenende.
Danke und Gruß
Florian-BGL
Hallo,
hast Du nicht im Objektkatalog (und/oder in der VBA-Hilfe) nachgesehen?
.
.
.
Set OutMail = Out.Items(intz)
.
OutMail.Printout
.
.
.
Zu den anderen Effekten kann ich nicht viel sagen... Die Applikationen müssen den "print"-Befehl unterstützen und dieser muss auch in der Registry als Command registriert sein.