Speicherpfad aus Zelle

Function MakeSureDirectoryPathExists Lib "imagehlp.dll" ( _
ByVal DirPath As String) As Long

Sub Send_Mitgl_sport()
Dim strPATH As String
Dim strFILE As String
Dim olApp As Object
Dim strBody As String, strSubj As String
Dim strTo As String
With ActiveSheet
strPATH = "D:\Freud und Leid\Test\" 'Dies aus Zelle auslesen
MakeSureDirectoryPathExists strPATH
strFILE = strPATH & .Range("A2") & ".pdf"
strTo = .Range("A1") 'Absenderadresse
End With
Dim wksPDF As Worksheet
'Set wksPDF = Worksheets("Info")
Set wksPDF = ActiveSheet
wksPDF.ExportAsFixedFormat _
Type:=xlTypePDF, _
Filename:=strFILE, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False
'erstellt Mailobjekt mit Outlook
strBody = vbLf & "Mit sportlichen Grüßen" _
& vbLf & vbLf & "Gerd Mustermann"
strSubj = "Freud & Leid- Kasse"
Set olApp = CreateObject("Outlook.Application")
With olApp.CreateItem(0)
.To = strTo
'.cc
'.bcc
'Wichtigkeit Hoch (1 = normal, 0 = niedrig)
'.importance = 2
.Subject = strSubj
.Body = strBody    'wenn ausgeblendet, wird Standard-Signatur eingefügt
'.BodyFormat = 2   'olFormatHTML
'.ReadReceiptRequested = True    'Lesebestätigung anfordern
.Attachments.Add strFILE
.display
'.send
End With
Set wksPDF = Nothing
Set olApp = Nothing
End Sub