Hallo Franz, du hattest mir seinerzeit bei ähnlicher Frage sehr geholfen! Nun habe ich einen Großteil des Moduls für eine neue Anwendung kopiert, aber leider kommt ein Zeitlauffehler: (2147024894 80070002) bei folgendem Modul:
Private Sub SpeichernEmails_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim reportName As String
Dim fileName As String
Dim PDFDateiName As String
Dim Firma As String
Dim KurzFirma As String
Dim Land As String
Dim Land1 As String
Dim Email As String
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
Set db = CurrentDb
Set rs = db.OpenRecordset("SELECT KurzFirma, Land, Email FROM abf_Hersteller")
Do Until rs.EOF
Firma = rs!KurzFirma
Land1 = rs!Land
Email = rs!Email
PDFDateiName = Land1 & "-" & Firma & ".pdf"
reportName = "ber_Hersteller_Profile_einzeln"
DoCmd.OpenReport reportName, acViewPreview, , "[KurzFirma] = '" & Firma & "'"
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
emailTo = Trim(rs.Fields("Email").Value)
emailSubject = "Plattform"
emailText = "Sehr geehrte Damen und Herren," & vbCrLf & "in beigefügter Anlage finden Sie Ihr Profil." & vbCrLf & "Für Fragen stehen wir Ihnen gerne zur Verfügung und verbleiben" & vbCrLf & vbCrLf _
& "mit freundlichen Grüßen" & vbCrLf & vbCrLf & "ToBu" & vbCrLf
Set outMail = outApp.CreateItem(olMailItem)
outMail.Attachments.Add PDFDateiName
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Display
outMail.Save
DoCmd.Close acReport, reportName, acSaveNo
rs.MoveNext
Loop
rs.Close
Was muss noch anders eingestellt werden? Könntest du freundlicherweise wieder helfen?
Danke!
Gruß ToBu
Zitat von: ToBu am Mai 15, 2024, 15:47:46PDFDateiName = Land1 & "-" & Firma & ".pdf"
Damit eine Datei zuverlässig gefunden werden kann, solltest du den vollständigen Pfad, inkl. Laufwerk und Ordner angeben.
Hallo PhilS, danke für die rasche Antwort! Da ich den Bericht aus Access in PDF drucke, aber nicht speichere, gibt es ja keinen Pfad und Ordner. Das Speichern will ich mir aus Zeitgründen ja ersparen, es soll ja direkt in Entwurf gespeichert werden.
Zitat von: ToBu am Mai 15, 2024, 18:13:16Da ich den Bericht aus Access in PDF drucke, aber nicht speichere, gibt es ja keinen Pfad und Ordner.
Das ist ein Problem. Die
Attachments.Add-Methode (https://learn.microsoft.com/en-us/office/vba/api/outlook.attachments.add?f1url=%3FappId%3DDev11IDEF1%26l%3Den-US%26k%3Dk(vbaol11.chm176)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv16)%26rd%3Dtrue) eines
Outlook.Mailitem kann aber nur mit einer Datei umgehen. Ohne Datei bekommst du den "Datei nicht gefunden"-Fehler, den du festgestellt hast.
Danke PhilS, da brauch ich mich ja nicht mehr weiter im Kreis zu drehen! Vielen Dank für die Erlösung!!! Oder gibt es vielleicht doch eine andere Methode aus deinem Erfahrungsschatz, die ich auch nachvollziehen kann?
Zitat von: ToBu am Mai 15, 2024, 20:04:02Oder gibt es vielleicht doch eine andere Methode aus deinem Erfahrungsschatz, die ich auch nachvollziehen kann?
Mit fällt ad-hoc keine ein, bei der sich der Aufwand lohnen würde.
Du schriebst oben:
Zitat von: ToBu am Mai 15, 2024, 18:13:16Das Speichern will ich mir aus Zeitgründen ja ersparen
Was meinst du damit genau? Die Zeit die es dauert das PDF zu speichern? Wie lange dauert das bei deinem Bericht effektiv? Hast du sehr viele Berichte, die du versenden willst, dass das so relevant wird?
Momentan sind es 140 PDFs. Das dauert ca. 1 1/2 min. Ist eigentlich auch zu vernachlässigen! Aber danke für deine Anregungen und Hinweise. Habe dann das Speichern versucht. Aber da kommt auch eine Fehlermeldung beim Attachment strFilename = PDFDateiName:
Private Sub SpeichernEmails_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim reportName As String
Dim fileName As String
Dim strSQL As String
Dim PDFDateiName As String
Dim PfadName As String
Dim Pfad As String
Dim Firma As String
Dim KurzFirma As String
Dim Land As String
Dim Land1 As String
Dim Email As String
Dim strFolder As String, strFilename As String
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim Pfad_Ordner As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
Set db = CurrentDb
strSQL = "SELECT * FROM abf_Aktueller_Pfad_Ordner"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
Pfad = rs!PDFPfad & "/"
rs.MoveNext
Loop
rs.Close
Set FS = CreateObject("Scripting.FileSystemObject")
Set Folder = FS.GetFolder(Pfad)
For Each File In Folder.Files
File.Delete
Next
Set rs = db.OpenRecordset("SELECT KurzFirma, Land, Email FROM abf_Hersteller")
Do Until rs.EOF
Firma = rs!KurzFirma
Land1 = rs!Land
Email = rs!Email
PDFDateiName = Land1 & "-" & Firma & ".pdf"
PfadName = Pfad & PDFDateiName
reportName = "ber_Hersteller_Profile_einzeln"
DoCmd.OpenReport reportName, acViewPreview, , "[KurzFirma] = '" & Firma & "'"
DoCmd.OutputTo acOutputReport, reportName, acFormatPDF, PfadName
DoCmd.Close acReport, reportName, acSaveNo
'Stop
'rs.MoveNext
'Loop
'rs.Close
'Stop
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
emailTo = Trim(rs.Fields("Email").Value)
emailSubject = "Plattform"
emailText = "Sehr geehrte Damen und Herren," & vbCrLf & "in beigefügter Anlage finden Sie Ihr Profil." & vbCrLf & "Für Fragen stehen wir Ihnen weiterhin gerne zur Verfügung und verbleiben" & vbCrLf & vbCrLf _
& "mit freundlichen Grüßen" & vbCrLf & vbCrLf & "ToBu" & vbCrLf
'emailAttachments:
Set outMail = outApp.CreateItem(olMailItem)
strFilename = PDFDateiName
Do Until strFilename = ""
outMail.Attachments.Add strFilename
strFilename = Dir()
Loop
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
'outMail.Display
outMail.Save
Stop
rs.MoveNext
Loop
rs.Close
PS: Die Anweisung outMail.Attachments.Add strFilename ist gelb hinterlegt! Der Inhalt von strFilename wird korrekt wiedergegeben! Keine Ahnung, warum es damit nicht läuft! Danke für Ratschläge!
strFilename = PDFDateiName
Do Until strFilename = ""
outMail.Attachments.Add strFilename
strFilename = Dir()
LoopDie Schleife sieht unfertig und damit nichtfunktionabel aus. Hier könntest Du Dir testweise ausgeben lassen, was und wieviel da ausgegeben wird.
Inhaltlich: Wenn oben die PDF in Schleife erzeugt werden, könnte man sich diese gleich merken (Array, kommagetrennter String) und sich daraus bedienen, statt das Filesystem auslesen zu wollen (und das nicht beherrscht).
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Do Until rs.EOF
Pfad = rs!PDFPfad & "/"
rs.MoveNext
Loop
rs.CloseHier macht eine Schleife wenig Sinn. Die Variable Pfad wird den letzten zugewiesenen Wert behalten, die Vorzuweisungen sind umsonst.
Zitat von: ToBu am Mai 15, 2024, 22:18:15PS: Die Anweisung outMail.Attachments.Add strFilename ist gelb hinterlegt! Der Inhalt von strFilename wird korrekt wiedergegeben!
Das würde ich nochmal hinterfragen...
Zitat von: ToBu am Mai 15, 2024, 22:12:46Pfad = rs!PDFPfad & "/"
Bei Windows Dateisystemen wird der Backslash als Pfad-Trenner verwendet. Du verwendest an dieser Code-Stelle einen Forward-Slash. - Ich habe meine Zweifel, ob das Access und Outlook so für korrekt halten.
Ich schließe mich
@ebs17 an, dass, unabhängig von diesem konkreten Laufzeitfehler, in deinem Code einiges logisch nicht so ganz plausibel erscheint.
Hallo PhilS, danke für deine Hinweise! Ich habe die alles auf "\" umgestellt und die Prozeduren geteilt!
1. Die PDF-Dateien werden aus den Berichten in einem Ordner korrekt gespeichert.
2. Die PDFs sollen nun aus dem Ordner gelesen werden und in Outlook als Anhang in Entwürfe gespeichert werden.
Die Emailentwürfe werden auch dort abgelegt, aber leider ohne die dazugehörigen PDFs aus dem Ordner. Mir fehlt wieder das Verständnis für die richtige Syntax! Meine Prozedur sieht so aus:
Private Sub EmailsInEntwürfe_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim reportName As String
Dim fileName As String
Dim criteria As String
Dim strSQL As String
Dim PDFDateiName As String
Dim PfadName As String
Dim Pfad As String
Dim Firma As String
Dim KurzFirma As String
Dim Land As String
Dim Land1 As String
Dim Email As String
Dim strFilename As String
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim Pfad_Ordner As String
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
Set db = CurrentDb
strSQL = "SELECT * FROM abf_Aktueller_Pfad_Ordner"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Pfad = rs!PDFPfad
rs.Close
Set rs = db.OpenRecordset("SELECT KurzFirma, Land, Email FROM abf_Hersteller")
Do Until rs.EOF
Firma = rs!KurzFirma
Land1 = rs!Land
Email = rs!Email
PDFDateiName = Land1 & "-" & Firma & ".pdf"
PfadName = Pfad & PDFDateiName
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
emailTo = Trim(rs.Fields("Email").Value)
emailSubject = ">>>Neu: Plattform <<<"
emailText = "Sehr geehrte Damen und Herren," & vbCrLf & "in beigefügter Anlage finden Sie Ihr Profil." & vbCrLf & "Für Fragen stehen wir Ihnen gerne zur Verfügung und verbleiben" & vbCrLf _
Set outMail = outApp.CreateItem(olMailItem)
strFilename = Dir(PfadName)
outMail.Attachments.Add strFilename
strFilename = Dir()
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Display
outMail.Save
Stop
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
End Sub
Kannst du mir eine funktionierende VBA-Anweisung geben?
Vielen Dank!
Zitat von: ToBu am Mai 16, 2024, 19:35:12strSQL = "SELECT * FROM abf_Aktueller_Pfad_Ordner"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Pfad = rs!PDFPfad
Vorher hattest du da noch den (falschen) Forward-Slash angehängt.
Hast du jetzt sichergestellt, dass der Pfad aus der Abfrage am Ende einen Backslash hat? Andernfalls kommt da kein gültiger, vollständiger Pfad zustande, wenn du später den Dateinamen anhängst.
Zitat von: ToBu am Mai 16, 2024, 19:35:12 Set outMail = outApp.CreateItem(olMailItem)
strFilename = Dir(PfadName)
outMail.Attachments.Add strFilename
strFilename = Dir()
Was soll das
Dir hier bezwecken?
Egal was die Intention davon war/ist, es sabotiert deinen Code! Der Rückgabewert von
Dir(PfadName) ist dann wieder der Dateiname ohne Pfad, wie er vorher in
PDFDateiName gespeichert war.
(Vorausgesetzt,
PfadName enthielt überhaupt einen gültigen Dateinamen, s.o.)
Hallo PhilS, danke für deine Geduld und Antwort mit den präzisen Schlussfolgerungen!
Ich habe alle "/" in "\" geändert, auch in meiner Access-Pfad-Tabelle, in der ich den letzten "\" hinzugefügt habe. Daher erscheint dieser nicht mehr in der VBA-Anweisung.
Ich finde es toll, dass du mit deiner Erfahrung direkt den "Finger in die Wunde" legst!
In der Tat kann ich dir nicht erklären, warum ich diese DIR-Funktion überhaupt eingebracht habe! Ich weiß auch nicht, was das überhaupt bedeutet! An anderer Stelle hatte das wohl Sinn gemacht, so dass ich dies mit kopiert habe!
Deswegen habe ich nun beide DIR-Anweisungen gelöscht! Und siehe da, es funktioniert! Für mich erstaunlicherweise, da in der Zeile: PfadName = Pfad & PDFDateiName die Inhalte von Pfad wie auch von PDFDateiName korrekt wiedergegeben werden, aber in PfadName lediglich der Inhalt von Pfad und nicht von Pfad und PDFDateiName.
Das gleiche auch in Zeile: strFilename = PfadName (ohne den Namen der anzuhängenden PDFDateiName Datei).
Kannst du mir das noch erklären, warum es jetzt dennoch funktioniert?
Auf jeden Fall erst einmal vielen Dank für sämtliche Hinweise!!!
Gruß ToBu
Nachtrag: Wie kann man verhindern, dass nach Ablauf der Prozedur in Outlook alle Emails noch geöffnet sind und geschlossen werden müssen? Gibt es eine Anweisung, mit der Outlook geschlossen wird und damit alle geöffneten Emails?
Zitat von: ToBu am Mai 17, 2024, 20:36:02Für mich erstaunlicherweise, da in der Zeile: PfadName = Pfad & PDFDateiName die Inhalte von Pfad wie auch von PDFDateiName korrekt wiedergegeben werden, aber in PfadName lediglich der Inhalt von Pfad und nicht von Pfad und PDFDateiName.
Ich denke, da hast du bei der Beobachtung des Verhaltens etwas falsch wahrgenommen.
PfadName enthält sowohl den Pfad als auch den eigentlichen Dateinamen, sonst kann das nicht funktionieren.
Zitat von: ToBu am Mai 17, 2024, 20:54:09Wie kann man verhindern, dass nach Ablauf der Prozedur in Outlook alle Emails noch geöffnet sind und geschlossen werden müssen?
Du könntest am Ende der Schleife, vor dem Loop, das Mailitem schließen:
outMail.Close(olSave)Outlook kannst du natürlich auch komplett schließen:
outApp.QuitAber viele Benutzer werden das absolut nicht mögen, weil sie Outlook während der Arbeit gern ständig geöffnet haben.
Hallo PhilS,
zu deiner Aussage "Ich denke, da hast du bei der Beobachtung des Verhaltens etwas falsch wahrgenommen. PfadName enthält sowohl den Pfad als auch den eigentlichen Dateinamen, sonst kann das nicht funktionieren." kann ich nur sagen, dass in PfadName der Inhalt von PDFName nicht mit rüber kommt! Wenn ich mit der Mouse bei einem Stop über die Variablen gehe, wird der Inhalt ja angezeigt, und es fehlt einfach der PDFName! In der Schleife funktioniert seltsamerweise nur der Durchlauf des 1. Datensatzes perfekt! Beim 2. Durchlauf gibt es eine Fehlermeldung 462. Ich stehe wieder auf dem Schlauch! Vielleicht kannst du nochmal helfen? Hängt es an dem Einfügen des outMail.Close (olSave) ? Ist es tatsächlich richtig, dieses vor dem Loop zu setzen und nicht vor dem rs.MoveNext ?
Hier nochmal meine aktuelle VBA:
Set db = CurrentDb
strSQL = "SELECT * FROM abf_Aktueller_Pfad_Ordner"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Pfad = rs!PDFPfad
rs.Close
Set rs = db.OpenRecordset("SELECT KurzFirma, Land, Email FROM abf_Hersteller")
Do Until rs.EOF
Firma = rs!KurzFirma
Land1 = rs!Land
Email = rs!Email
PDFDateiName = Land1 & "-" & Firma & ".pdf"
PfadName = Pfad & PDFDateiName
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
emailTo = Trim(rs.Fields("Email").Value)
emailSubject = ">>>Neu: Plattform <<<"
emailText = "Sehr geehrte Damen und Herren," & vbCrLf & "in beigefügter Anlage finden Sie Ihr Profil." & vbCrLf & "Für Fragen stehen wir Ihnen gerne zur Verfügung und verbleiben" & vbCrLf _
Set outMail = outApp.CreateItem(olMailItem)
strFilename = PfadName
outMail.Attachments.Add strFilename
outMail.To = emailTo
outMail.Subject = emailSubject
'outMail.Body = emailText
outMail.Display
outMail.Save
'Stop
rs.MoveNext
outMail.Close (olSave)
Loop
rs.Close
Hallo PhilS, nach einigen fehlgeschlagenen Versuchen habe ich nun endlich die bei mir funktionierende Position für die Anweisung outMail.Close (oISave) gefunden! Vielen Dank nochmals an dich und alle anderen für die Beiträge und Kommentare, die mich weitergebracht haben! Für alle Interessierten hier nun die Lösung der VBA Anwendung :) :
Private Sub EmailsInEntwürfe_Click()
Dim db As DAO.Database
Dim rs As DAO.Recordset
Dim reportName As String
Dim fileName As String
Dim criteria As String
Dim strSQL As String
Dim PDFDateiName As String
Dim PfadName As String
Dim Pfad As String
Dim Firma As String
Dim KurzFirma As String
Dim Land As String
Dim Land1 As String
Dim Email As String
Dim strFilename As String
Dim emailTo As String
Dim emailSubject As String
Dim emailText As String
Dim Pfad_Ordner As String
Dim I As Integer
Dim outApp As Outlook.Application
Dim outMail As Outlook.MailItem
Dim outlookStarted As Boolean
Set db = CurrentDb
strSQL = "SELECT * FROM abf_Aktueller_Pfad_Ordner"
Set rs = db.OpenRecordset(strSQL, dbOpenDynaset)
Pfad = rs!PDFPfad
rs.Close
I = 0
Set rs = db.OpenRecordset("SELECT KurzFirma, Land, Email FROM abf_Hersteller")
Do Until rs.EOF
I = I + 1
Firma = rs!KurzFirma
Land1 = rs!Land
Email = rs!Email
PDFDateiName = Land1 & "-" & Firma & ".pdf"
PfadName = Pfad & PDFDateiName
On Error Resume Next
Set outApp = GetObject(, "Outlook.Application")
On Error GoTo 0
If outApp Is Nothing Then
Set outApp = CreateObject("Outlook.Application")
outlookStarted = True
End If
emailTo = Trim(rs.Fields("Email").Value)
emailSubject = ">>>Neu: Plattform <<<"
emailText = "Sehr geehrte Damen und Herren," & vbCrLf & "in beigefügter Anlage finden Sie Ihr Profil." & vbCrLf & "Für Fragen stehen wir Ihnen gerne zur Verfügung und verbleiben" & vbCrLf _
Set outMail = outApp.CreateItem(olMailItem)
strFilename = PfadName
outMail.Attachments.Add strFilename
outMail.To = emailTo
outMail.Subject = emailSubject
outMail.Body = emailText
outMail.Display
outMail.Save
outMail.Close (olSave)
rs.MoveNext
Loop
rs.Close
Set rs = Nothing
Set db = Nothing
If outlookStarted Then
outApp.Quit
End If
Set outMail = Nothing
Set outApp = Nothing
MsgBox "Alle " & I & " Emails in Entwürfe gespeichert!"
End Sub
Zitat von: ToBu am Mai 21, 2024, 15:16:44nach einigen fehlgeschlagenen Versuchen habe ich nun endlich die bei mir funktionierende Position für die Anweisung outMail.Close (oISave) gefunden!
Dort wo du es jetzt hast, am Ende des Blocks zu outMail, ist es auch gut aufgehoben, weil es einen logischen Kontext zusammenfasst.
Für die Funktion des Codes macht es aber absolut überhaupt gar keinen Unterschied!
An den Problemen mit "nur ein Durchlauf" ändert das nichts.