Aggiornamento contatti outlook da excel con vba

Question

Salve,

scrivo in merito a quanto riportato nella pagina seguente:

https://answers.microsoft.com/it-it/msoffice/forum/msoffice_excel-mso_win10-mso_2013_release/sincronizzare-excel-con-outlook/6ec41f5e-9eed-4b0e-ad0b-d5540fe3c4b3?page=1

Ho riscontrato un problema quando viene fatto un confronto con le celle excel contenenti caratteri speciali quali: ., (), &, % etc.

Se il nome dell'azienda contiene uno dei caratteri suddetti il programma non va avanti e non vengono aggiunti nuovi contatti.

C'è un modo per sistemare questo inconveniente?

Cordiali saluti

Francesco

Answer 1

Ciao  Francesco,

Problema risolto sostituendo al posto di Chr(34) le virgolette! 

Grazie molte Norman!

Prego! -:)

Alla prossima.

===

Regards,

Norman

Ciao Norman,

ho riscontrato ancora degli incovenienti quando si cerca di compilare il codice:

se si utilizza il codice & Chr(34) & sStr & Chr(34) i contatti che hanno delle virgolette non vengono copiati e bloccano la compilazione come succedeva prima;

se al posto di Chr(34) si usano le virgolette ogni volta che viene fatto girare il programma vengono aggiunti gli account anche se presenti già sulla rubrica.

Hai per caso dei suggerimenti al riguardo?

Ti ringrazio anticipatamente

Francesco

Answer 2

Ciao  Francesco,

Problema risolto sostituendo al posto di Chr(34) le virgolette! 

Grazie molte Norman!

Prego! -:)

Alla prossima.

===

Regards,

Norman

Answer 3

Problema risolto sostituendo al posto di Chr(34) le virgolette! 

Grazie molte Norman!

Answer 4

Ciao Norman,

il programma funziona se vengono tolte le righe: 

 .l

            MsgBox .LastModificationTime

Continua comunque a bloccarsi quando incontra nomi che presentano le virgolette "  "  .

Saluti

Francesco

Answer 5

Ciao Francesco,

scrivo in merito a quanto riportato nella pagina seguente:

https://answers.microsoft.com/it-it/msoffice/forum/msoffice_excel-mso_win10-mso_2013_release/sincronizzare-excel-con-outlook/6ec41f5e-9eed-4b0e-ad0b-d5540fe3c4b3?page=1

Ho riscontrato un problema quando viene fatto un confronto con le celle excel contenenti caratteri speciali quali: ., (), &, % etc.

Se il nome dell'azienda contiene uno dei caratteri suddetti il programma non va avanti e non vengono aggiunti nuovi contatti.

C'è un modo per sistemare questo inconveniente?

Prova a sostituire il codice con la seguente versione:

'=========>>

Option Explicit

'--------->>

Public Sub Tester()

    Dim WB As Workbook

    Dim SH As Worksheet

    Dim Rng As Range

    Dim oOutlook As Outlook.Application

    Dim oNamespace As Outlook.Namespace

    Dim oFolder As Outlook.MAPIFolder

    Dim oContactItems As Outlook.Items

    Dim oContactItem As Outlook.ContactItem

    Dim i As Long

    Dim LRow As Long, iCols As Long

    Dim sStr As String

    Const sFoglio As String = "Foglio1"                             '<<=== Modifica

    Const iRigaIntestazioni As Long = 1                            '<<=== Modifica

    Const sColonne As String = "A:J"                                 '<<=== Modifica

    Set oOutlook = New Outlook.Application

    Set oNamespace = oOutlook.GetNamespace("MAPI")

    Set oFolder = oNamespace.GetDefaultFolder(10)

    Set oContactItems = oFolder.Items

    Set WB = ThisWorkbook

    Set SH = WB.Sheets(sFoglio)

    On Error GoTo XIT

    With SH

        LRow = LastRow(SH, .Columns("A:J"))

        iCols = .Columns(sColonne).Columns.Count

        Set Rng = .Columns(sColonne).Resize(LRow - iRigaIntestazioni + 1, iCols)

    End With

    For i = 2 To Rng.Rows.Count

        With Rng

            sStr = .Cells(i, 1).Value

        End With

        If oContactItems.Find _

           ("[CompanyName]= " & Chr(34) & sStr & Chr(34)) Is Nothing Then

            Set oContactItem = oContactItems.Add

        Else

            Set oContactItem = _

            oContactItems.Find("[CompanyName] = " & Chr(34) & sStr & Chr(34))

        End If

        With oContactItem

            .l

            MsgBox .LastModificationTime

            .CompanyName = SH.Cells(i, 1)

            .BusinessAddressStreet = Cells(i, 2).Value

            .BusinessAddressCity = Cells(i, 4).Value

            .Business2TelephoneNumber = SH.Cells(i, 7)

            .Email2Address = SH.Cells(i, 10)

            .Save

        End With

    Next i

    Call MsgBox( _

         Prompt:="I contatti sono stati con aggiornati!", _

         Buttons:=vbInformation, _

         Title:="REPORT")

XIT:

    Set oContactItem = Nothing

    Set oContactItems = Nothing

    Set oFolder = Nothing

    Set oNamespace = Nothing

    Set oOutlook = Nothing

    Application.ScreenUpdating = True

End Sub

'--------->>

Public Function LastRow(SH As Worksheet, _

                        Optional Rng As Range, _

                        Optional minRow As Long = 1)

    If Rng Is Nothing Then

        Set Rng = SH.Cells

    End If

    On Error Resume Next

    LastRow = Rng.Find(What:="*", _

                       after:=Rng.Cells(1), _

                       Lookat:=xlPart, _

                       LookIn:=xlFormulas, _

                       SearchOrder:=xlByRows, _

                       SearchDirection:=xlPrevious, _

                       MatchCase:=False).Row

    On Error GoTo 0

    If LastRow < minRow Then

        LastRow = minRow

    End If

End Function

'<<=========

===

Regards,

Norman