AW: VBA: PDF an mehrere Mailadressen senden
29.09.2020 17:39:21
Nepumuk
Hallo Janek,
teste mal:
Option Explicit
Private Type FILES
Path() As String
End Type
Public Sub Pdf()
Dim objDropdown As Shape, objCell As Range
Dim objOutlook As Object, objMail As Object
Dim objDictionary As Object
Dim strPath As String, strMailAddress As String, avntMailAddress As Variant
Dim i As Long, ialngFilesIndex As Long, ialngTempIndex As Long
Dim lngIndex As Long, ialngPathIndex As Long
Dim audtFiles() As FILES
Set objOutlook = CreateObject(Class:="Outlook.Application")
Set objDictionary = CreateObject(Class:="Scripting.Dictionary")
'Tabellennamen anpassen
With ThisWorkbook.Worksheets("Anschreiben")
'Name des Dropdownfeldes anpassen
Set objDropdown = .Shapes("Dropdown 6")
For i = 1 To objDropdown.ControlFormat.ListCount
objDropdown.ControlFormat.Value = i
If Trim$(.Range("A7").Text) <> vbNullString Then
strPath = "C:\Users\Acer\Desktop\" & .Range("A21").Text & ".pdf"
.ExportAsFixedFormat Type:=xlTypePDF, Filename:=strPath, _
Quality:=xlQualityStandard, IncludeDocProperties:=True, _
IgnorePrintAreas:=False, OpenAfterPublish:=False
DoEvents
Set objCell = ThisWorkbook.Worksheets("Betreiberliste").Columns(1).Find( _
What:=.Range("A21").Text, LookIn:=xlValues, LookAt:=xlWhole, MatchCase:=True)
strMailAddress = objCell.Offset(0, 6).Text
If objDictionary.Exists(Key:=strMailAddress) Then
ialngTempIndex = objDictionary.Item(Key:=strMailAddress)
Redim Preserve audtFiles(ialngTempIndex).Path(UBound(audtFiles(ialngTempIndex).Path) + 1)
audtFiles(ialngTempIndex).Path(UBound(audtFiles(ialngTempIndex).Path)) = strPath
Else
Redim Preserve audtFiles(ialngFilesIndex)
Redim audtFiles(ialngFilesIndex).Path(0)
audtFiles(ialngFilesIndex).Path(0) = strPath
objDictionary.Item(Key:=strMailAddress) = ialngFilesIndex
ialngFilesIndex = ialngFilesIndex + 1
End If
End If
Next i
End With
avntMailAddress = objDictionary.Keys
For lngIndex = LBound(avntMailAddress) To UBound(avntMailAddress)
Set objMail = objOutlook.CreateItem(0)
With objMail
.To = avntMailAddress(lngIndex)
.Subject = "Betreff"
.Body = "Hallo"
ialngTempIndex = objDictionary.Item(Key:=avntMailAddress(lngIndex))
For ialngPathIndex = LBound(audtFiles(ialngTempIndex).Path) To UBound(audtFiles(ialngTempIndex).Path)
.Attachments.Add audtFiles(ialngTempIndex).Path(ialngPathIndex)
Next
.Display ' Anzeigen
'.Send ' Direkt senden
End With
Next
Set objDropdown = Nothing
Set objCell = Nothing
Set objMail = Nothing
Set objOutlook = Nothing
Set objDictionary = Nothing
End Sub
Gruß
Nepumuk