Speichern unter Dialog auslesen
08.03.2022 10:20:53
Marco
ich habe eine Frage. Bzw. Ich stehe auf dem Schlauch.
Ich habe ein Makro, was aus einem Tabellenblatt ein PDF Dokument speichert. Der Speicherort wird aber durch den Benutzer selbst gewählt. Der Ordner selbst ist zwar vorgegeben, dieser hat aber dann noch weitere Unterordner, die variieren. Der Benutzer speichert dann in einem dieser Unterordner oder legt sich selbst einen an. Sprich, der Pfad ist immer variabel.
Im Anschluss soll diese Datei versendet werden. Und genau hier liegt das Problem. Wie lese ich jetzt den Pfad aus, den der Benutzer ausgewählt hat, um dann die Datei als Anhang einzufügen.
Hier mein bisheriger Code. Der Debugger zeigt den Fehler bei : strDatei = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
Danke für die Hilfe!
Lg Marco
Pfad = "P:\BPDBR\EINSATZBEFEHLE\"
Datei = ActiveSheet.Range("B131")
Worksheets("Abschlussmeldung").Visible = True
Worksheets("Abschlussmeldung").Activate
Set outObj = CreateObject("Outlook.Application")
Set Mail = outObj.CreateItem(0)
'** Blatt in Verzeichnis abspeichern
If Datei = "" Then
MsgBox "Zelle einhält keinen Eintrag"
Exit Sub
End If
Endg = ".pdf"
If InStr(Datei, Endg) = 0 Then 'Prüfung ob Zelle bereits Endung enthält
Datei = Datei & Endg
End If
Filter = "PDF (*" & Endg & "), *" & Endg
File = Application.GetSaveAsFilename(Pfad & Datei, Filter)
Sheets("Abschlussmeldung").ExportAsFixedFormat Type:=xlTypePDF, Filename:=File, IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
strDatei = Application.FileDialog(msoFileDialogSaveAs).SelectedItems(1)
'** Pfad und Dateiname der neuen Datei zwischenspeichern
'** Betreff-Text festlegen
strSubjectText = "Abschlussmeldung vom " & Range("E8").Value & " aus dem Bereich " & Range("L8").Value & " - " & Range("E9").Value
'** Nachrichten-Text festlegen
strBodyText = "" & "Sehr geehrte Damen und Herren,
" & _
"anbei übersende ich Ihnen den Lagebericht vom " & Range("E8").Value & " aus dem Bereich " & Range("L8").Value & ".
" & _
"Mit freundlichen Grüßen.
" & _
"gez. " & Range("U6").Value & "
" & _
Range("E9").Value & "
"
'**Range("B10").Value & Chr(13) & _
'**Range("E10").Value & Chr(13) & Chr(13) & Chr(13) & _
'**Range("B35").Value & Chr(13) & _
'**Range("E35").Value
'** Mail erzeugen
With Mail
.To = Range("U5").Value 'Empfänger
.CC = Range("U1").Value 'Kopie an Empfänger
.Subject = strSubjectText 'Betreff
.BodyFormat = 2 '2 = HTML, 1 = Text
.Attachments.Add strDatei 'Anhang
.HTMLBody = strBodyText & strSignature
End With