Dim ExcelceOUT As Boolean
'Bülent Öztürk - 12.04.2012 - www.excelce.net/forum
Sub OutlookaExceldenAdresEkle()
Dim ekle As Boolean
ekle = ExcelceAdresEkle
End Sub
Function ExcelceAdresEkle() As Boolean
' Excel sayfa başlıkları:
'1. satırda başlıklar...
' A sütunu: Adı
' B sütunu: Soyadı
' C sütunu: Email
' D sütunu: Firma
' E sütunu: İş tel
' F sütunu: İş Fax
' G sütunu: Ev tel
' H sütunu: Cep tel
On Error GoTo Hata
Dim Satir As Long
Dim Sutun As Long
Dim Say As Long
Dim KisiDetay As Variant
Dim ExcelceKisi As Object ' Outlook.ContactItem
Dim Kisi_ad As String
Dim Kisi_soyad As String
Dim Kisi_mail As String
Dim Kisi_firma As String
Dim Kisi_firma_tel As String
Dim Kisi_firma_fax As String
Dim Kisi_ev_tel As String
Dim Kisi_cep_tel As String
Satir = Sayfa1.Range(Range("A1"), Range("A" & Rows.Count).End(xlUp)).Count
Sutun = Sayfa1.Range(Range("A1"), Range("IV1").End(xlToLeft)).Count
ReDim KisiDetay(1 To Satir, 1 To Sutun)
KisiDetay = Range(Cells(2, 1), Cells(Satir + 1, Sutun))
Dim olApp As Object ' Outlook.Application
Set olApp = GetOutlookApp
Say = 1
Do Until Say = Satir
Kisi_ad = KisiDetay(Say, 1)
Kisi_soyad = KisiDetay(Say, 2)
Kisi_mail = KisiDetay(Say, 3)
Kisi_firma = KisiDetay(Say, 4)
Kisi_firma_tel = KisiDetay(Say, 5)
Kisi_firma_fax = KisiDetay(Say, 6)
Kisi_ev_tel = KisiDetay(Say, 7)
Kisi_cep_tel = KisiDetay(Say, 8)
Set ExcelceKisi = olApp.CreateItem(2)
With ExcelceKisi
.FirstName = Kisi_ad
.LastName = Kisi_soyad
.Email1Address = Kisi_mail
.CompanyName = Kisi_firma
.BusinessTelephoneNumber = Kisi_firma_tel
.BusinessFaxNumber = Kisi_firma_fax
.HomeTelephoneNumber = Kisi_ev_tel
.MobileTelephoneNumber = Kisi_cep_tel
End With
ExcelceKisi.Close 0 ' olSave
Say = Say + 1
Loop
ExcelceAdresEkle = True
GoTo Bitir
Hata:
ExcelceAdresEkle = False
Bitir:
Set ExcelceKisi = Nothing
If ExcelceOUT Then
olApp.Quit
End If
Set olApp = Nothing
End Function
Function GetOutlookApp() As Object
On Error Resume Next
Set GetOutlookApp = GetObject(, "Outlook.Application")
If Err.Number <> 0 Then
Set GetOutlookApp = CreateObject("Outlook.Application")
ExcelceOUT = True
End If
On Error GoTo 0
End Function