Problema al ejecutar un script en visual basic.

[taboacar]

Buenos dias,

Tengo un script realizado en visual basic que manda emails automaticamente cogiendo las direcciones de un fichero excel. El problema surge cuando el array que contiene las direcciones no me funciona bien. El error que me da es el siguiente.

Error: This key is already associated with an element of this collection.
Code: 800A01C9.
Line:80
Col: 2

El codigo del script es el siguiente:

Código vb:

'======== DEF. VARIABLES =============
 
'Fichero con la lista de nombres y emails
Dim mailsFile
mailsFile = "listaEmails.xls"
 
'Texto del email
Dim textoEmail
textoEmail = "Buenos días" & "<br>" & "<br>" & "Os adjunto los préstamos de >8 días." & "<br>" & "Por favor, actualizad vuestros comentarios en LMT, necesitamos que nos indiquéis lo antes posible, la fecha y detalles de su devolución, nº de Loreto o nº de Pareto <a href=""https://lmt6.atlanta.hp.com/LMTHome_IGSO.aspx""> https://lmt6.atlanta.hp.com/LMTHome_IGSO.aspx </a>" & "<br>" & "<br>" & "Gracias" & "<br>" & "Un saludo" & "<br>" & "Elena"
 
'Asunto del email
Dim asuntoEmail
asuntoEmail = "Loans >8 Días"
 
'Variable que define si se incluye el manager en copia
Dim incluirManager
incluirManager = True
 
'Emails que se incluyen siempre en copia
Dim emailsCopia
emailsCopia = "[email protected]; [email protected]; "
 
 
'Directorio de ejecución del programa
Dim directorioActual
directorioActual = left(WScript.ScriptFullName,(len(WScript.ScriptFullName))-(len(WScript.ScriptName)))
 
'Ruta del fichero de log
Dim ruta, fechahora
fechahora = Now
ruta = directorioActual & "LOG Script Email [" & replace(asuntoEmail,">","MAS") & "] - " & replace( replace(fechahora, "/", "_"), ":", ".") & ".txt"
 
Dim filesList
filesList = ListFolder (directorioActual, "xls", directorioActual & mailsFile)
 
'============ MAIN ===================
 
'Muestra ventana de aviso de inicio del script
WScript.Echo("Inicio del Script Email [" & asuntoEmail & "]")
 
'Crea el fichero de log y escribe la cabecera
WriteOpenFileText(ruta), ("LOG - ENVÍO EMAILS" & vbCrLf & "[" & asuntoEmail & "]" & vbCrLf & fechahora & vbCrLf & "##############" & vbCrLf)
 
'Abrir el fichero de [nombres - emails] y copiar la información en un array
Dim listaEmails
 
'Abre Excel
Set appExcel = CreateObject("Excel.Application")
appExcel.Workbooks.Open (directorioActual & mailsFile), false, true
Set hojaActual = appExcel.ActiveWorkbook.Worksheets(1)
'Obtiene numero de filas de la hoja 1
numFilas = hojaActual.UsedRange.Rows.Count
 
'Crea el diccionario donde se guardarán los nombres y emails
Set listaEmails = CreateObject("Scripting.Dictionary")
For i=0 to (numFilas-1) 
    listaEmails.Add hojaActual.Cells(i+1, 1).Value, hojaActual.Cells(i+1, 2).Value  
Next
 
'Cierra la lista de emails
appExcel.Workbooks.Close
 
'Abrir la aplicación Microsoft Outlook
Set MyApp = CreateObject("Outlook.Application")
 
'Crear diccionario para los nombres de cada fichero Excel
Dim listaNombres
Set listaNombres = CreateObject("Scripting.Dictionary")
 
'Variable para guardar el nombre del manager
Dim nombreManager
 
'Recorre los ficheros Excel encontrados en la carpeta
For Each fich In filesList
    'Direcciones de email de copia
    Dim direccionesCc
    direccionesCc = emailsCopia
    
    'Abrir el fichero Excel
    appExcel.Workbooks.Open (fich), false, true
    'Obtener todos los nombres de los destinatarios
    Set hojaActual = appExcel.ActiveWorkbook.Worksheets(1)
    
    'Obtiene el nombre del manager
    nombreManager = hojaActual.Cells(2, 1).Value
    'Obtiene los nombres de la columna 2
    numFilas = hojaActual.UsedRange.Rows.Count
    For i=2 to (numFilas) 
        If Not listaNombres.Exists(hojaActual.Cells(i, 2).Value) Then
            listaNombres.Add hojaActual.Cells(i, 2).Value, hojaActual.Cells(i, 2).Value
        End If
    Next
        
    'Nombres encontrados en el fichero Excel (sin repetir)
    Dim arrayTmp
    arrayTmp = listaNombres.Items
    
    'Diccionario que guardará los emails enviados para no repetirlos
    Dim emailsEnviados
    Set emailsEnviados = CreateObject("Scripting.Dictionary")
    
    'Escribe info del fichero en el log
    WriteOpenFileText(ruta), ("FICHERO <" & fich & ">:" & vbCrLf)
    
    'Cadena que almacena el destinatario del email (concatenación de direcciones)
    Dim destinatario
    destinatario = ""
    
    'Cadenas que almacenan los registros de envío
    Dim noEncontrados
    noEncontrados = ""
    
    Dim enviados
    enviados = ""
    
    'Bucle que recorre los nombres encontrados en el fichero Excel para obtener sus emails
    For Each nombre in arrayTmp
        'Obtiene el email que corresponde al nombre
        Dim email
        email = listaEmails.Item(nombre)
        'Si no lo ha enviado ya a la misma dirección y la dirección es distinta de "", envía el email.
        If (Not emailsEnviados.Exists(email)) And (email<>"") Then
            'Almacena la dirección a la que se ha enviado
            emailsEnviados.Add email, email
            destinatario = destinatario & email & "; "
            'Escribe info del mail enviado en el log
            enviados = enviados & nombre & " / " & email & vbCrLf
        ElseIf email="" Then
            'Escribe info del nombre no encontrado en el log
            noEncontrados = noEncontrados & nombre & vbCrLf
        End If  
    Next
    
    'Añade al manager como copia si es necesario
    If incluirManager Then
        email = listaEmails.Item(nombreManager)
        If (email<>"") Then
            direccionesCc = direccionesCc & email
            'Escribe info del mail enviado en el log
            enviados = enviados & nombreManager & " / " & email & " (Manager)" & vbCrLf
        Else
            'Escribe info del nombre no encontrado en el log
            noEncontrados = noEncontrados & nombre & " (Manager)" & vbCrLf
        End If  
    End If
    
    'Envía el correo a la dirección de email con el texto predefinido y adjuntando el fichero Excel
    Set MyItem = MyApp.CreateItem(0)
    With MyItem
        .To = destinatario
        .Cc = direccionesCC
        .Subject = asuntoEmail & " - " & right (fich, len (fich) - len (directorioActual))
        .ReadReceiptRequested = False
        .HTMLBody = textoEmail
        .Attachments.Add fich
    End With
    'MyItem.Send
    'MyItem.Display
    Set MyItem = Nothing
        
    'Vacía la lista de nombres para usarla con el próximo fichero Excel
    listaNombres.RemoveAll
    'Cierra el fichero Excel
    appExcel.Workbooks.Close
    
    'Escribe el registro
    WriteOpenFileText(ruta), ("ENVIADOS:" & vbCrLf & enviados)
    If noEncontrados<>"" Then
        WriteOpenFileText(ruta), ("NO ENCONTRADOS:" & vbCrLf & noEncontrados & vbCrLf & "------------" & vbCrLf)
    Else
        WriteOpenFileText(ruta), ("------------" & vbCrLf)
    End If
Next
 
'myApp.Quit
appExcel.Quit
 
 
 
'======== DEF. FUNCIONES =============
 
'
'<ListFolder>
'Lista los ficheros de la ruta indicada que tengan la extensión indicada (no incluye subcarpetas),
' a excepción del fichero cuyo nombre está en el parámetro exceptionFile.
'Devuelve un array con el resultado.
'
Function ListFolder (path, extension, exceptionFile)
    Dim filesList()
    Dim index
    index = 0
 
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objFolder = objFSO.GetFolder(path)
    Set colFiles = objFolder.Files
 
    For Each objFile In colFiles
        If ((Right(objFile, len(extension)+1) = "." & extension) And objFile<>exceptionFile) Then
            Redim Preserve filesList (index)
            filesList (index) = objFile
            index = index+1 
        End If
    Next
    
    ListFolder = filesList
End Function
 
'
'<WriteOpenFileText>
'Función que escribe el texto indicado en sText al final del fichero determinado por la ruta sFilePath.
'Si el fichero no existe, lo crea.
'
Function WriteOpenFileText(sFilePath, sText)
    Dim objFSO 'As FileSystemObject
    Dim objTextFile 'As Object
    
    Const ForReading = 1
    Const ForWriting = 2
    Const ForAppending = 8
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    Set objTextFile = objFSO.OpenTextFile(sFilePath, ForAppending, True)
    
    ' Write a line.
    objTextFile.Write ( sText & vbCrLf)
    objTextFile.Close
 
End Function
 

He estado mirando y dice que es porque duplico la calve del array, pero no encuentro ningún tipo de solución al respecto.

Muchas gracias de antemano.

Un saludo