|
Tengo la costumbre de guardar todos o casi todos los correos. Esto tiene el inconveniente de que el archivo pst va creciendo mucho y manejar un archivo de 500 megas es ... digamos incómodo. Planteé la cuestón de cómo se podrían eliminar ciertos adjuntos sin eliminar el correo y nuestra compañera Marta (MVP de Office) me remitió a http://www.outlookcode.com/codedetail.aspx?id=70 Probé esa macro y funciona perfectamente. No tenéis más que copiar/pegar en un archivo .bas e importarlo directamente el OL 2003. Esta macro graba los adjuntos de los correos seleccionados a una carpeta del disco y luego elimina éste añadiendo una referencia en el correo. Sólo hice una ligera modificación para que si no se selecciona ninguna carpeta para guardar los adjuntos no haga nada. Otra cosa a tener en cuenta: si la extensión del adjunto está bloqueada por OL (por ejemplo .exe) se deberá desbloquear previamente.
Teniendo este código es relativamente sencillo modificar la macro a nuestro gusto. Por ejemplo, para que elimine los correos de cierto tamaño al cabo de cierto tiempo ... En fin, sólo hace falta un poco de imaginación y tirar de Google ;-) Si lo deseáis podéis descargar el script ya hecho desde nuestra sección de descargas.
------------------------- NO COPIAR ESTA LINEA --------------------------- Attribute VB_Name = "Módulo1"
Sub SaveAttachment()
'Declaration
Dim myItems, myItem, myAttachments, myAttachment As Object
Dim myOrt As String
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection 'Ask for destination folder
myOrt = InputBox("Destino de los adjuntos", "Guarda adjuntos", "C:\") On Error Resume Next
If myOrt <> "" Then
'work on selected items
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
'for all items do...
For Each myItem In myOlSel
'point on attachments
Set myAttachments = myItem.Attachments
'if there are some...
If myAttachments.Count > 0 Then
'add remark to message text
myItem.Body = myItem.Body & vbCrLf & "Adjuntos eliminados:" & vbCrLf
'for all attachments do...
For i = 1 To myAttachments.Count
'save them to destination
myAttachments(i).SaveAsFile myOrt & myAttachments(i).DisplayName
'add name and destination to message text
myItem.Body = myItem.Body & "Archivo: " & myOrt & myAttachments(i).DisplayName & vbCrLf
Next i
'for all attachments do...
While myAttachments.Count > 0
'remove it (use this method in Outlook XP)
myAttachments.Remove 1
'remove it (use this method in Outlook 2000)
'myAttachments(1).Delete
Wend
'save item without attachments
myItem.Save
End If
Next
End If 'free variables
Set myItems = Nothing
Set myItem = Nothing
Set myAttachments = Nothing
Set myAttachment = Nothing
Set myOlApp = Nothing
Set myOlExp = Nothing
Set myOlSel = Nothing
End Sub
------------------------- NO COPIAR ESTA LINEA ---------------------------
Trackback(0)
 |
TrackBack URI para esta entrada
RSS feed Comments