Public Sub ImportaContatto()
StrErrore = ""
On Error GoTo Errore
'variabile per la verifica del dubpplicato
Dim BlnDubblicato As Boolean
'variabile per la gestione degli elementi di outlook
Dim nms As Outlook.NameSpace
Dim itms As Outlook.Items
Dim itm As Outlook.MailItem
Dim ItmContatto As Outlook.ContactItem
Dim Riservatezza As String
Riservatezza = "Normale"
'oggetto mapi
Set nms = Application.GetNamespace("MAPI")
Set fld = nms.Folders(1).Folders("Contatti")
Set itms = fld.Items
'Inizializzo l'oggetto
Set ItmContatto = itms.Add(olContactItem)
'Titolo
ItmContatto.Title = "Titolo"
'Nome
ItmContatto.FirstName = "Emanuele"
'Secondonome
ItmContatto.NickName = "Alias"
'Cognome
ItmContatto.LastName = "Mattei"
'Società
ItmContatto.Companies = "EmaMattei"
'Professione
ItmContatto.Profession = "Sviluppatore"
'Viauff
ItmContatto.BusinessAddress = "Via M. Roma"
'Città uff
ItmContatto.BusinessAddressCity = "Roma"
'Provinciauff
ItmContatto.BusinessAddressCountry = "Roma"
'CAPuff
ItmContatto.BusinessAddressPostalCode = "00131"
'Paeseuff
ItmContatto.BusinessAddressCountry = "Italia"
'Viaab
ItmContatto.HomeAddressStreet = "Via M. Sabino"
'Viaab2 '
ItmContatto.OtherAddressStreet = "Nessuna"
'Cittàab
ItmContatto.HomeAddressCity = "Roma"
'Provinciaab
ItmContatto.HomeAddressCountry = "Roma"
'CAPab
ItmContatto.HomeAddressPostalCode = "00131"
'Paeseab
ItmContatto.HomeAddressState = "Italia"
'Altracittà
ItmContatto.OtherAddressCity = "Catania"
'Altraprovincia
ItmContatto.OtherAddressCountry = "Catania"
'AltroCAP
ItmContatto.OtherAddressPostalCode = "00000"
'Altropaese
ItmContatto.OtherAddressState = "Italia"
'Ufficio
ItmContatto.BusinessAddress = "Via Rubelia"
'Telefonoauto
ItmContatto.CarTelephoneNumber = "33919800XX"
'Faxab
ItmContatto.HomeFaxNumber = "33919800XX"
'Faxuff
ItmContatto.BusinessFaxNumber = "33919800XX"
'Telefonoprincipalesocietà
ItmContatto.Business2TelephoneNumber = "33919800XX"
'ISDN
ItmContatto.ISDNNumber = 39339939393#
' Cellulare
ItmContatto.MobileTelephoneNumber = "33919800XX"
'Altrofax
ItmContatto.OtherFaxNumber = "33919800XX"
'Cercapersone
ItmContatto.CallbackTelephoneNumber = "33919800XX"
'Telefonoprincipale
ItmContatto.HomeTelephoneNumber = "33919800XX"
'Telefonoprincipale
ItmContatto.PrimaryTelephoneNumber = "33919800XX"
'Radiotelefono
ItmContatto.RadioTelephoneNumber = "33919800XX"
'AltroindirizzoCasellapostale
ItmContatto.OtherAddressPostOfficeBox = "altra via"
'Categorie
ItmContatto.Categories = "Sport"
'CodFiscPIVA
ItmContatto.GovernmentIDNumber = "393939939993"
'Compleanno
ItmContatto.Birthday = CDate("31/12/1974")
'Datifatturazione
ItmContatto.BillingInformation = "Fattura a Società"
'Iniziali
ItmContatto.Initials = "EM"
'Luogo
ItmContatto.Department = "Roma"
'Nomeconiuge
ItmContatto.Spouse = "Mattei"
'PaginaWeb
ItmContatto.WebPage = "blog.shareoffice.it/emanuele"
'Indirizzopostaelettronica
ItmContatto.Email1Address = "emanuelemattei@dominio.it"
'Tipopostaelettronica
ItmContatto.Email1AddressType = "SMTP"
'Nomevisualizzatopostaelettronica
ItmContatto.Email1DisplayName = "Emanuele Mattei"
'Indirizzopostaelettronica2
ItmContatto.Email2Address = "emanuelemattei@dominio.it"
'Tipopostaelettronica2
ItmContatto.Email2AddressType = "SMTP"
'Nomevisualizzatopostaelettronica2
ItmContatto.Email2DisplayName = "Emanuele Mattei"
'Indirizzopostaelettronica3
ItmContatto.Email3Address = "emanuelemattei@dominio.it"
'Tipopostaelettronica3
ItmContatto.Email3AddressType = "SMTP"
'Nomevisualizzatopostaelettronica3
ItmContatto.Email3DisplayName = "Emanuele Mattei"
'Priorità
ItmContatto.Importance = olImportanceNormal
'Riservatezza
Select Case Riservatezza
Case "Confidenziale"
ItmContatto.Sensitivity = olConfidential
Case "Normale"
ItmContatto.Sensitivity = olNormal
Case "Personale"
ItmContatto.Sensitivity = olPersonal
Case "Privato"
ItmContatto.Sensitivity = olPrivate
End Select
' Anniversario
ItmContatto.Anniversary = "31/12/2974"
'Figli
ItmContatto.Children = "Nessuno"
'Hobby
ItmContatto.Hobby = "Calcio"
'Lingua
ItmContatto.Language = "Italiano"
'Nomeassistente
ItmContatto.AssistantName = "Pino"
'Notes
ItmContatto.Body = "Note"
'Verifico che il contatto esista
Dim myContacts As Outlook.Items
Dim myItems As Outlook.Items
Dim myItem As Object
BlnDubblicato = False
Set myContacts = nms.GetDefaultFolder(olFolderContacts).Items 'myNamespace.GetDefaultFolder(olFolderContacts).Items
Set myItems = myContacts.Restrict("[LastName] = 'Mattei' AND [FirstName] ='Emanuele'")
'
For Each myItem In myItems
'verifico se cercare il cognome o nome
If (myItem.Class = olContact And myItem.NickName = "Alias") Then
'non salvo
BlnDubblicato = True
Exit For
End If
Next
'salvo
If BlnDubblicato = False Then ItmContatto.Close olSave
'chiudo il recordset e libero la memoria
Exit Sub
Errore:
StrErrore = Err.Description
MsgBox (StrErrore)
End Sub