VBA: Inserire un nuovo appuntamento, contatto e promemoria ad Outlook 2007

In questo articolo vedremo come utilizzare Visual BAsic Application, per aggiungere nuovi appuntamenti, o contatti oppure nuovi promemoria, ad Outlook 2007.

il
Sviluppatore Microsoft .Net, Collaboratore di IProgrammatori

Inserire in Outlook, un appuntamento per il calendario

Il frammento di codice riportato qui di seguito, permette in Outlook 2007,  tramite Visual Basic Application, di inserire un nuovo appuntamento nel calendario di outlook, solo nel caso che la descrizione di tale appuntamento non è già presente.
 
Public Sub ImportaCalendario()
    StrErrore = ""
    On Error GoTo Errore
    'variabili per la gestione del db
  
   'variabile per la gestione degli elementi di outlook
   Dim nms As Outlook.NameSpace
   Dim itms As Outlook.Items
   Dim itm As Outlook.MailItem
   'oggetto per la ricorrenza
   Dim ObjRecurrPatt As Outlook.RecurrencePattern
 
   Dim strCartella As String
   Dim fFound As Boolean
   'oggetto mapi
   Set nms = Application.GetNamespace("MAPI")
   Dim fld  As Folder
  Set fld = nms.Folders(1).Folders("Calendario")
  
  
 
Dim promemoria As Boolean
promemoria = True
Intcontatore = 0
'variabile per la riservatezza
Dim Riservatezza As String
Riservatezza = "Normale"
'oggetto calendario
Dim itmCa As Outlook.AppointmentItem
 
  
        'imposto l'oggetto item con la cartella calendario
        Set itms = fld.Items
        'inizializzo l'oggetto calendario
        Set itmCa = itms.Add(olAppointmentItem)
        'oggetto
        itmCa.Subject = "oggetto"
        'Datainizio
        itmCa.Start = #12/12/2007#
        'intervallo - dopo 30 minuti
        itmCa.Duration = 30
        'Datafine
        itmCa.End = #12/12/2007#
        'Giornataintera
        itmCa.AllDayEvent = True
        'Promemoria attivato
        If promemoria = True Then
            'itmCa.RecurrenceState = True
            Set ObjRecurrPatt = itmCa.GetRecurrencePattern
            ObjRecurrPatt.RecurrenceType = olRecursDaily
            'Datapromemoria
            ObjRecurrPatt.PatternStartDate = "12/12/2007 17:50"
            ObjRecurrPatt.PatternEndDate = "12/12/2007 17:55"
        End If
        'Categorie
        itmCa.Categories = "Sport"
 
        'Descrizione
        itmCa.Body = "descrizione"
        'Priorità
        itmCa.Importance = olImportanceNormal
        'riservetezza
            Select Case Riservatezza
                Case "Confidenziale"
                    itmCa.Sensitivity = olConfidential
                Case "Normale"
                    itmCa.Sensitivity = olNormal
                Case "Personale"
                    itmCa.Sensitivity = olPersonal
                Case "Privato"
                    itmCa.Sensitivity = olPrivate
            End Select
        Dim BlnTrovato As Boolean
         BlnTrovato = False
        'Verifico che l'attività esista
        Dim myContacts As Outlook.Items
        Dim myItems As Outlook.Items
        'singolo elemento trovato
        Dim myItem As Object
        Set myContacts = nms.GetDefaultFolder(olFolderCalendar).Items
        
        Set myItems = myContacts.Restrict("[Subject] = 'oggetto'")
        For Each myItem In myItems
            'controllo la classe e la descrizione per avere certezza che l'appuntamento non è stato già inserito
            If (myItem.Class = olAppointment And myItem.Body = "descrizione") Then
                'In questo caso esistre lo elimino
                myItem.Delete
                'esco dal ciclo
                Exit For
            End If
        Next
   'salvo tutti gli item creati
   itmCa.Close (olSave)
 
    Exit Sub
   
Errore:
  
    StrErrore = Err.Description
    MsgBox (StrErrore)
   
End Sub

 

Inserire una nuova attività in Outlook 2007.
Il frammento di codice qui di seguito, inserisce una nuova attività in Outlook 2007, solo nel caso che l'oggetto non è già presente
 
Public Sub ImportaAttività()
StrErrore = ""
On Error GoTo Errore
 
   'variabile per la gestione degli elementi di outlook
   Dim nms As Outlook.NameSpace
   Dim itms As Outlook.Items
   Dim itm As Outlook.MailItem
   'attivita
   Dim ItmAtt As Outlook.TaskItem
   'varie impostazioni.
   Dim strCartella As String
   Dim fFound As Boolean
   'oggetto mapi
   Set nms = Application.GetNamespace("MAPI")
      Set fld = nms.Folders(1).Folders("Attività")
 
   Set itms = fld.Items
Dim Promemoria As Boolean
Promemoria = True
'riservatezza
Dim Riservatezza As String
Riservatezza = "Normale"
Dim Stato As String
Stato = "Progresso"
       
Dim BlnDuplicato As Boolean
  
   BlnDuplicato = False
 
        'Istanzio l'oggetto contatto
         Set ItmAtt = itms.Add(olTaskItem)
         'oggetto
         ItmAtt.Subject = "Oggetto"
         'Datainizio
         ItmAtt.StartDate = "12/12/2007"
         'Scadenza
         ItmAtt.DueDate = "12/12/2007"
         'Promemoriaattivatodisattivato
         If Promemoria = True Then
            ItmAtt.ReminderSet = True
            ItmAtt.ReminderTime = "12/12/2007"
         End If
         'Datacompletamento
         ItmAtt.DateCompleted = "14/12/2007"
         'Percentuale di completamento
          ItmAtt.PercentComplete = 30
        
         'Lavorostimato
          ItmAtt.TotalWork = 150
        
         'Lavoroeffettivo
          ItmAtt.ActualWork = 65
         'Categorie
          ItmAtt.Categories = "Sport"
         'Contatti
          ItmAtt.ContactNames = "Emanuele"
 
         'Indennitàtrasferta
          ItmAtt.Mileage = "Roma"
 
         'Notes
         ItmAtt.Body = "Note"
         'PrioritàSchedule da 1 a 9 1 è la più alta
          ItmAtt.SchedulePlusPriority = "1"
         'Priorità
          ItmAtt.Importance = olImportanceNormal
 
        
         'Riservatezza
            Select Case Riservatezza
                Case "Confidenziale"
                    ItmAtt.Sensitivity = olConfidential
                Case "Normale"
                    ItmAtt.Sensitivity = olNormal
                Case "Personale"
                    ItmAtt.Sensitivity = olPersonal
                Case "Privato"
                    ItmAtt.Sensitivity = olPrivate
            End Select
        
        'ruolo
         ItmAtt.Role = "impiegato"
         'Società
         ItmAtt.Companies = "Mattei"
         'Stato
     
            Select Case Stato
                Case "Completo"
                    ItmAtt.Status = olTaskComplete
                Case "Differito"
                    ItmAtt.Status = olTaskDeferred
                Case "Progresso"
                    ItmAtt.Status = olTaskInProgress
                Case "Non Avviato"
                    ItmAtt.Status = olTaskNotStarted
                Case "In attesa"
                    ItmAtt.Status = olTaskWaiting
            End Select
   
     
        'Verifico che l'attività esista
        Dim myContacts As Outlook.Items
        Dim myItems As Outlook.Items
        Dim myItem As Object
        Set myContacts = nms.GetDefaultFolder(olFolderTasks).Items
        Set myItems = myContacts.Restrict("[StartDate] = ""#" & Format("12/12/2007", "dd/m/yyyy") & "#""") ' Format(recDati!Datainizio, "ddddd h:nn AMPM")) ' & "'")  ''" & CDate(recDati!Datainizio) & "'")
        For Each myItem In myItems
            If (myItem.Class = olTask And myItem.Subject = "Oggetto") Then
                'non salvo
                BlnDubblicato = True
                Exit For
               
            End If
        Next
      If BlnDubblicato = False Then ItmAtt.Close 0
       
  
    Exit Sub
   
Errore:
 
    StrErrore = Err.Description
    MsgBox (StrErrore)
   
End Sub
 

Inserire un nuovo contatto in Outlook 2007.

Il frammento di codice, qui di seguito, inserire un nuovo contatto in Outlook 2007, tramite il linguaggio Visual Basic Application, solo nel caso che l'alias non è già presente.
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