Aus Excel definierten Email account ansprechen

Sub SeriendruckVS()
'** Dimensionierung der Variablen
Dim strPDF As String
Dim OutlookApp As Object, strEmail As Object
Dim olOldBody As String
Dim wksData As Worksheet, wksPrint As Worksheet
Dim iRow As Integer
Dim FolderPDF As String, File_PDF As String
On Error GoTo Fehler
Set wksData = Worksheets("Mitgliederdaten")
Set wksPrint = ActiveWorkbook.Worksheets("VS")
iRow = 7
ActiveWorkbook.Worksheets("VS").Unprotect PWs
FolderPDF = ActiveWorkbook.Path & Application.PathSeparator & "_11_E-Mail"
If Dir(FolderPDF, vbDirectory) = "" Then
VBA.MkDir FolderPDF
End If
FolderPDF = FolderPDF & Application.PathSeparator
Do Until IsEmpty(wksData.Cells(iRow, 1))
If UCase(wksData.Cells(iRow, 22).Value) = "C" Then 'Wert in Spalte D prüfen
wksPrint.Range("T1").Value = wksData.Cells(iRow, 1).Value 'lfd. Nr
wksPrint.Calculate '? - wenn Formelberechnungen aktualisiert werden müssen
File_PDF = FolderPDF & wksPrint.Range("A6").Text & "_" _
& wksPrint.Range("A7").Text & ".pdf" 'Zellen und verbindenden Text ggf. anpassen
wksPrint.ExportAsFixedFormat Type:=xlTypePDF, Filename:=File_PDF, _
Quality:=xlQualityStandard, IgnorePrintAreas:=False, OpenAfterPublish:=False
Set OutlookApp = CreateObject("Outlook.Application")
Set strEmail = OutlookApp.CreateItem(0)
With strEmail
Set .SendUsingAccount = .Session.Accounts.Item(2)
olOldBody = .htmlBody
.To = wksData.Cells(iRow, 10).Value
.Subject = "Vertrag Amateursportler" & " " & Worksheets("GD").Range("$W$2"). _
Value
.body = "Hallo" & " " & wksPrint.Range("A7").Value & "," & Chr(13) & Chr(13) &  _
_
"anbei dein Vertrag als Amateursportler" & " " & Worksheets("GD").Range("$W$2").Value & " " & " _
zur weiteren Verwendung."
.Display    'Mail nur Anzeigen Nicht senden
VBA.SendKeys "^{END}", True
'Einfügen einer bestimmten Signatur
strSignatur = "SKK Willmering"
'strSignatur = "meineFirmenSignatur"
.GetInspector.CommandBars.Item("Insert").Controls("Signatur").Controls(strSignatur). _
_
Execute
.Attachments.Add File_PDF
.send
Sleep 15000  ' 2 Sekunden warten
Dim olApp    As Object
Dim olName   As Object
Dim olFolder As Object
Dim olMail   As Object
Set olApp = GetObject(, "OutLook.Application")
Set olName = olApp.GetNamespace("MAPI")
Set olFolder = olName.Session.Folders("SKK Willmering").Folders("Gesendete Objekte")
Set olMail = olFolder.Items.GetLast
olMail.SaveAs FolderPDF & Format(Date, "yymmdd") & "_" & "VS" & "_" & wksPrint.Range("A6").Text  _
& "_" & wksPrint.Range("A7").Text & ".msg", 3
On Error Resume Next
End With
Kill File_PDF
End If
iRow = iRow + 1
Loop
ActiveWorkbook.Worksheets("VS").Protect PWs
Err.Clear
Fehler:
End Sub