'======== 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
'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