Email aus Excel mit Auswahl des Kontakts

[Volume1]

Hallo zusammen,

ich habe beruflich täglich mit mehreren Partnern Kontakt per Email und verschickte Tabellen aus Excel,
hierbei kopiere ich die Tabelle nach Outlook und versende die Email, bzw. wird die ganze Exceldatei verschickt.
Natürlich sehr umständlich und aufwendig.
Ich habe Online schon einige Makros gefunden um die Excel Tabelle direkt aus Excel per Email zu verschicken, allerdings habe ich bisher kein Makro gesehen, beidem ich meine ganzen Kontakte hinterlegen kann und dann den Betroffenen Kontakt vor dem versenden auswählen kann. Vielleicht in einem kleinen Dropdown Menü?

Evtl. hat jemand eine Idee bzw. nutzt so ein Makro bereits?

Vielen Dank

[volti]

Hallo,

zum Importieren Deiner Kontakte könntest Du z.B. nachfolgendes Makro als Anregung hernehmen.
Entweder komplett in eine Tabelle importieren oder nur die gewünschten Items entsprechend verwenden.

Dann kann man, je nachdem wie es gedacht ist, dort eine DropDownBox drauflegen oder eine Userform usw. und aus dieser auswählen.

Oder hattest Du an etwas anderes gedacht?

Code:

Option Explicit

Const csDats = "Name,Vorname,eMail-Adresse,Telefon privat,Mobil privat,Straße,Ort,Land,Firma,Telefon geschäftlich,Mobil geschäftlich,Straße,Ort,Land,Homepage,Geburtstag,Notizen"

Sub Kontakte_aus_Outlook_Importieren()
 Dim oOutContact As Object, i As Integer, iZeile As Long
 Dim WSh As Worksheet, oFolder As Object, T As String
 
 Set WSh = ThisWorkbook.Sheets("Kontakte")
 WSh.Cells(1, "A").Value = "Outlook-Kontaktliste"
 WSh.Cells(2, "A").Resize(1, 17).Value = Split(csDats, ",")
 iZeile = 4
 
 With CreateObject("Outlook.Application")
  
  For Each oOutContact In .GetNamespace("MAPI").GetDefaultFolder(10).Items
    If TypeName(oOutContact) = "ContactItem" Then
     With oOutContact
        WSh.Cells(iZeile, "A").Value = .Lastname
        WSh.Cells(iZeile, "B").Value = .Firstname
        T = .Email1Address
        WSh.Cells(iZeile, "C").Value = T
        WSh.Hyperlinks.Add Anchor:=WSh.Cells(iZeile, "C"), Address:="mailto:" & T, TextToDisplay:=T
        WSh.Cells(iZeile, "D").Value = .HomeTelephoneNumber
        WSh.Cells(iZeile, "E").Value = .MobileTelephoneNumber
        WSh.Cells(iZeile, "F").Value = .HomeAddressPostalCode & " " & .HomeAddressCity
        WSh.Cells(iZeile, "G").Value = .HomeAddressCountry
        WSh.Cells(iZeile, "H").Value = .HomeAddressStreet
        WSh.Cells(iZeile, "I").Value = .CompanyName
        WSh.Cells(iZeile, "J").Value = .BusinessTelephoneNumber
        WSh.Cells(iZeile, "K").Value = .BusinessAddressPostalCode & " " & .BusinessAddressCity
        WSh.Cells(iZeile, "L").Value = .BusinessAddressCountry
        WSh.Cells(iZeile, "M").Value = .BusinessHomePage
        WSh.Cells(iZeile, "N").Value = .Birthday
        WSh.Cells(iZeile, "O").Value = .body
     End With
    End If
  Next oOutContact
 
 End With

End Sub

____________________
viele Grüße aus Freigericht
Karl-Heinz

[Volume1]

Hi, 

Vielen Dank, ich werde das gleich probieren und mich wieder melden.

Lg