VBScript  – Guardar los archivos adjuntos catalogado por remitente y Eliminar adjunto del Correo

El siguiente VBScript es una variante de los publicados en el articulo “VBScript – Guarda los archivos adjuntos dentro de la carpeta del Remitente catalogado con fecha” Este VBScript crea una carpeta para cada remitente y va catalogando los archivos adjuntos dentro de carpetas por fecha y va eliminando los archivos adjuntos de los correos recibidos.

Respondiendo al comentario

Instrucciones de Uso

1.- Abrir el editor de Visual Basic (ALT+F11).

2.- Insertar un modulo nuevo (Insert > Module).

3.- Copiar el código VBScript.

4.- Guardamos y básicamente podria ser lo único requerido, pero podemos editar la ruta donde se crearan los directorios en la linea 17.

5.- Ahora debemos crear la regla que ejecute el Script cuando cumpla las condiciones.

Para mas información de configuración ver: Como utilizar el Editor VBA en Office (Utilizar Macros VBScript) y Outlook – Crear y configurar reglas

Código

Public Sub saveAttachtoDisk(itm As Outlook.MailItem)
Dim objAtt As Outlook.Attachment
Dim saveFolder As String
Dim dateFormat
Dim getFrom
Dim oFSO
Dim Att As Attachments
Dim lAttCount As Long
 
Set Att = itm.Attachments
lAttCount = Att.Count

Set oFSO = CreateObject("Scripting.FileSystemObject")
Set objShell = CreateObject("Wscript.Shell")
    dateFormat = Format(Now, "yyyy-mm-dd H-mm")
    getFrom = itm.SenderName
    saveFolder = "C:\Archivos\" & getFrom & "\" & dateFormat & "\"
    

    If Not oFSO.FolderExists(saveFolder) Then
         CreateDirs saveFolder
    End If

    For Each objAtt In itm.Attachments
          objAtt.SaveAsFile saveFolder & objAtt.DisplayName
          Set objAtt = Nothing
          'Set itm = Nothing
    Next
     
    While lAttCount > 0
        strFile = Att.Item(1).FileName & "; " & strFile
        Att(1).Delete
        lAttCount = Att.Count
    Wend
  
itm.Save
strFile = ""
 
Set myAttachment = Nothing
Set Att = Nothing

End Sub

Sub CreateDirs(MyDirName)

    Dim arrDirs, i, idxFirst, objFSO, strDir, strDirBuild
    Set objFSO = CreateObject("Scripting.FileSystemObject")
    strDir = objFSO.GetAbsolutePathName(MyDirName)
    arrDirs = Split(strDir, "\")

    If Left(strDir, 2) = "\\" Then
        strDirBuild = "\\" & arrDirs(2) & "\" & arrDirs(3) & "\"
        idxFirst = 4
    Else
        strDirBuild = arrDirs(0) & "\"
        idxFirst = 1
    End If

    For i = idxFirst To UBound(arrDirs)
        strDirBuild = objFSO.BuildPath(strDirBuild, arrDirs(i))
        If Not objFSO.FolderExists(strDirBuild) Then
            objFSO.CreateFolder strDirBuild
        End If
    Next

    Set objFSO = Nothing
End Sub
Leer:  VBScript - Adjuntar archivos automáticamente y enviar correo Outlook
Fernando O.

Fernando O.

Soy analista de sistemas actualmente trabajo en una empresa con mas de 200 empleados que utilizan equipo de computo al cual se les da soporte en el departamento.
Uno de mis pasatiempos fuera de la empresa es escribir artículos para PortalMasTips donde documento los problemas, inquietudes y detalles interesantes que se presentan.
Fernando O.

Latest posts by Fernando O. (see all)

7
Deja una respuesta

avatar
 
Archivos de fotos e imágenes
 
 
 
Archivos de audio y video
 
 
 
Otros tipos de archivos
 
 
 
4 Hilos de comentarios
3 Respuestas de hilo
0 Seguidores
 
Comentario más reaccionado
Hilo de comentarios más caliente
3 Autores de comentarios
alejandroFernando O.Alberto Autores de comentarios recientes

Este sitio usa Akismet para reducir el spam. Aprende cómo se procesan los datos de tus comentarios.

  Suscribir  
el más nuevo más antiguo más votado
Notificar de
Alberto
Guest
Alberto

Hola me gustaría mucho tu pagina, pregunta realice una macro en Excel para enviar correos masivos hay una forma de como eliminar Los correos enviados desde la macro que los envia? Me seria de mucha ayuda si me dieras una idea de como empezar

Alberto
Guest
Alberto

no me lo acepta ya le puse la variable que declaro por ejemplo

Mailapp.DeleteAfterSubmit = True
y no me deja
asip es como tengo mi parte del correo
for i= 1 To variable de correos

With Mailapp
.To =”correo”
.Subject = “hola”
.HTMLBody= Aqui pongo lo que lleva el cuerpo del correo
.Send
Segun yo deberia de ir aqui pero me sale error de compilacion
End With
next i

llevo como una semana aprendiendo este lenguaje y me esta gustando pero aun no se mucho de como utilizar sus propiedades no se si me puedas orientar mas

Alberto
Guest
Alberto

jajajaja, ya vi cual era mi error al era antes del .send poner

.DeleteAfterSubmit = true

Gracias por darme una idea… en verdad me sirvió de mucho.

alejandro
Guest
alejandro

Hola fer ya tengo todo listo , ahora queria agradecerte y al mismo tiempo hacerte una pregunta….
lo que yo necesito es que cuando me lleguen los correos me lleguen en formato original por ejemplo en html y no me lo cambie a archivo plano
hay alguna libreria o algo que me lo permita? me podrias ayudar?

Compartir
Twittear
Pin
Más en Outlook VBScript
VBScript – Guarda los archivos adjuntos dentro de la carpeta del Remitente catalogado con fecha

VBScript – Reenviar correo a Lista de distribución en CCO (Copia Oculta) Outlook

VBScript – Exportar Información de correos Outlook a Excel

Cerrar