AW: super Link, aber Frage noch offen (oT)
24.11.2005 10:55:19
Rocky
Ich bins nochmal,
hab hier mal noch ne Variante gefunden.
Sub KontakteVonOutlookNachExcel()
Dim KontaktOrdner As Object
Dim l As Long
Dim intMsgBox As Integer
Dim outl As New Outlook.Application
intMsgBox = MsgBox("Möchten Sie die Outlook-Adressen an der aktuellen Position einfügen?", _
vbQuestion + vbYesNo, "SmartTools Excel Weekly")
If intMsgBox = vbNo Then Exit Sub
Set olcontacts = outl.GetNamespace("MAPI"). _
GetDefaultFolder(olFolderContacts)
ActiveCell.Value = "Vorname"
ActiveCell.Offset(0, 1).Value = "Nachname"
ActiveCell.Offset(0, 2).Value = "Adresse"
ActiveCell.Offset(0, 3).Value = "Telefon"
ActiveCell.Offset(0, 4).Value = "Telefax"
ActiveCell.Offset(0, 5).Value = "E-Mail"
ActiveCell.Offset(0, 6).Value = "Geburtstag"
ActiveCell.Offset(1, 0).Select
For l = 1 To olcontacts.Items.Count
Set outobj = olcontacts.Items(l)
With outobj
ActiveCell.Value = .FirstName
ActiveCell.Offset(0, 1).Value = .LastName
ActiveCell.Offset(0, 2).Value = .BusinessAddress
ActiveCell.Offset(0, 3).Value = .BusinessTelephoneNumber
ActiveCell.Offset(0, 4).Value = .BusinessFaxNumber
ActiveCell.Offset(0, 5).Value = .Email1Address
ActiveCell.Offset(0, 6).Value = .Birthday
End With
ActiveCell.Offset(1, 0).Select
Next l
Set outobj = Nothing
Set olcontacts = Nothing
Set outl = Nothing
End Sub
Gruß Rocky