Outlook Adres Defterine Excelden Kişi Ekle (Makro ile)

[Bülent Öztürk]

Kod: [Seç]

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