none
Seleccionar libreta de direcciones para cargar contactos Outlook/ Exchange desde MsAccess RRS feed

  • Pregunta

  • Tengo un problema al cargar los contactos desde VBA MsAccess a outlook, ya que comparto la identidad de outlook con una identidad compartida de Exchange.
    El problema es que no soy capaz de saber donde me está grabando los contactos, y me gustaría que fuera en la identidad de Exchange que yo seleccione previamente, para compartir los contactos con mis compañeros.
    Os pego el código que utilizo.

    Gracias por anticipado

    El modelo de objetos del outlook, me es un poco complicado, y sospecho que no sé decirle en un SET, a qué libreta de direcciones debe ir                                                                                                                  

    EnricVinyals.

    Public Sub AddNewContact()
       Dim olApp As Outlook.Application:   Set olApp = CreateObject("Outlook.Application")
     ' Logon. Doesn't hurt if you are already running and logged on...
       Dim olNs As Outlook.Namespace:   Set olNs = olApp.GetNamespace("MAPI")
       olNs.Logon
    Dim strFechaCarga As String
    strFechaCarga = Year(Now()) & Format(Month(Now()), "00") & Format(Day(Now()), "00")
    Dim DateUpdate As Date: DateUpdate = Format(Day(Now), "00") & "/" & Format(Month(Now()), "00") & "/" & Year(Now())

     ' Create and Open a new contact.
       Dim olItem As Outlook.ContactItem:   Set olItem = olApp.CreateItem(olContactItem)
        Dim MiMdb As DAO.Database
        Set MiMdb = CurrentDb
        Dim MiRst As DAO.Recordset: Set MiRst = MiMdb.OpenRecordset("cAnexarContactsItems")
        MiRst.MoveLast: MiRst.MoveFirst

        Dim i As Byte: i = 0
    '///////////////////////////////////////////////////////////////////////////////////////////
    '///////////////////////////////////////////////////////////////////////////////////////////

        Do Until MiRst.EOF
             ' Setup Contact information...
                        With olItem

                            .FullName = IIf(IsNull(MiRst!FullName), "FullName is null", MiRst!FullName) 'nombre completo
                            .Birthday = DateUpdate                                                                   'aqui la fecha de actualizacion del registro
                            .CompanyName = MiRst!CompanyName 'organizacion
                            .HomeTelephoneNumber = Nz(MiRst!HomeTelephoneNumber) 'teléfono particular
                            .MobileTelephoneNumber = Nz(MiRst!MobileTelephoneNumber)
                            .Email1Address = Nz(MiRst!Email1Adress) 'correo electrónico
                            .JobTitle = Nz(MiRst!JobTitle) 'cargo
                            .BusinessAddress = MiRst!BusinessAddress 'dirección partiular
                            .BusinessTelephoneNumber = MiRst!BusinessTelephoneNumber
                            .BusinessAddressCity = MiRst!BusinessAddressCity
                            .BusinessAddressPostalCode = MiRst!BusinessAddressPostalCode
                            .BusinessAddressStreet = MiRst!BusinessAddress
                            .BusinessHomePage = Nz(MiRst!BusinessHomePage)
                            '.BusinessFaxNumber = Nz(MiRst!BusinessFaxNumber)
                            .Email1DisplayName = MiRst!Email1DisplayName
                            .CarTelephoneNumber = MiRst!CarTelephoneNumber                                                
                            .BusinessAddressState = MiRst!BusinessAddressState
                            .MobileTelephoneNumber = Nz(MiRst!MobileTelephoneNumber)     
                            .Title = Nz(MiRst!BusinessAddressPostOfficeBox)               

                           ' Save Contact...
                           .Save

                          'marco el registro como grabado en fecha

                           .Display
                           Sleep (1000)
                         End With

            MiRst.MoveNext

        Loop



        MiRst.Close

        Set MiRst = Nothing
        Set MiMdb = Nothing
            Set olItem = Nothing
        Set olNs = Nothing
        Set olApp = Nothing


        MsgBox "Final"


    End Sub

    jueves, 16 de febrero de 2017 14:25