para macro guardar descargar datos automaticamente automatically attachments archivo adjuntos adjunto vba outlook attachment outlook-vba

vba - macro - Guarde los archivos adjuntos en una carpeta y cámbieles el nombre



macro para descargar datos adjuntos de outlook (6)

Estoy tratando de obtener una macro de VBA en Outlook que guardará los archivos adjuntos de un correo electrónico en una carpeta específica y agregará la fecha de recepción al nombre del archivo.

Mi Google me ha llevado hasta aquí:

Public Sub saveAttachtoDisk (itm As Outlook.MailItem) Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim dateFormat As String saveFolder = "C:/Temp/" dateFormat = Format(Now, "yyyy-mm-dd H-mm") For Each objAtt In itm.Attachments objAtt.SaveAsFile saveFolder & "/" & dateFormat & objAtt.DisplayName Set objAtt = Nothing Next End Sub

La primera cosa obvia es que está aplicando la hora actual al nombre del archivo en lugar del tiempo recibido, pero parece que no puedo cambiarlo. Mi teoría es que el Outlook.Attachment no tiene un ReceivedTime y que el mismo correo electrónico debe ser referenciado.

En segundo lugar, esto no parece funcionar en absoluto, ¡ja! Funcionó el primer día que comencé a retocar, pero después de eso dejó de guardar archivos.

De hecho, lo resolvé poco después de la publicación, pero no pude publicar mi solución. Honestamente, no lo recuerdo Pero tuve que volver a visitar la tarea cuando me dieron un nuevo proyecto que enfrentaba el mismo desafío.

Usé la propiedad ReceivedTime de Outlook.MailItem para obtener la marca de tiempo, pude usar esto como un identificador único para cada archivo para que no se anulen entre sí.

Public Sub saveAttachtoDisk(itm As Outlook.MailItem) Dim objAtt As Outlook.Attachment Dim saveFolder As String saveFolder = "C:/PathToDirectory/" Dim dateFormat As String dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd Hmm ") For Each objAtt In itm.Attachments objAtt.SaveAsFile saveFolder & "/" & dateFormat & objAtt.DisplayName Next End Sub

Muchas gracias por las otras soluciones, muchas de ellas van más allá :)

Esta es mi secuencia de comandos Guardar datos adjuntos. Selecciona todos los mensajes de los que desea guardar los archivos adjuntos y guardará una copia allí. También agrega texto al cuerpo del mensaje que indica dónde se guarda el archivo adjunto. Podrías cambiar fácilmente el nombre de la carpeta para incluir la fecha, pero necesitarías asegurarte de que la carpeta existiera antes de comenzar a guardar los archivos.

Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem ''Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String '' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next '' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") '' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection '' Set the Attachment folder. strFolderpath = strFolderpath & "/Attachments/" '' Check each selected item for attachments. If attachments exist, '' save them to the strFolderPath folder and strip them from the item. For Each objMsg In objSelection '' This code only strips attachments from mail items. '' If objMsg.class=olMail Then '' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count strDeletedFiles = "" If lngCount > 0 Then '' We need to use a count down loop for removing items '' from a collection. Otherwise, the loop counter gets '' confused and only every other item is removed. For i = lngCount To 1 Step -1 '' Save attachment before deleting from item. '' Get the file name. strFile = objAttachments.Item(i).FileName '' Combine with the path to the Temp folder. strFile = strFolderpath & strFile '' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile '' Delete the attachment. objAttachments.Item(i).Delete ''write the save as path to a string to add to the message ''check for html and use html tags in link If objMsg.BodyFormat <> olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" Else strDeletedFiles = strDeletedFiles & "<br>" & "<a href=''file://" & _ strFile & "''>" & strFile & "</a>" End If ''Use the MsgBox command to troubleshoot. Remove it from the final code. ''MsgBox strDeletedFiles Next i '' Adds the filename string to the message body and save it '' Check for HTML body If objMsg.BodyFormat <> olFormatHTML Then objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body Else objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody End If objMsg.Save End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub

Se agregó código simple para guardar con un sello legible de fecha y hora.

Use sync2pst para sincronizar todos sus datos en Outlook con todos sus dispositivos, trabaje así:

  1. solo necesita comprar 1 licencia: guarde su archivo pst en una computadora (llamemos a este "servidor" de PC) en su red.
  2. cree tareas programadas que sincronicen el archivo pst en su ''servidor'' con todos los archivos pst en todos sus dispositivos, sin importar qué dispositivo descargue primero los correos electrónicos (necesita conocimientos de programación dos para omitir los archivos pst que están abiertos en el momento de sincronización) .
  3. guarde todos sus archivos adjuntos en la misma carpeta skydrive que se encuentra en el mismo lugar en todos sus dispositivos (por ejemplo, e: / skydrive / attachments)
  4. Use el siguiente código en todos sus dispositivos para guardar archivos adjuntos (cambie la ruta como se menciona arriba)

  5. Utilice SOLAMENTE UN archivo PST para todas sus cuentas, haga carpetas, subcarpetas y así ...

  6. en VBA: consulte '' microsoft scripting runtime de microsoft scripting runtime '' extra / referencias ... ''

  7. aquí está el código

Private Sub Application_NewMail() SaveAttachments End Sub Public Sub SaveAttachments() Dim objOL As Outlook.Application Dim objMsg As Outlook.MailItem ''Object Dim objAttachments As Outlook.Attachments Dim objSelection As Outlook.Selection Dim i As Long Dim lngCount As Long Dim strFile As String Dim strFolderpath As String Dim strDeletedFiles As String Dim fs As FileSystemObject '' Get the path to your My Documents folder strFolderpath = CreateObject("WScript.Shell").SpecialFolders(16) On Error Resume Next '' Instantiate an Outlook Application object. Set objOL = CreateObject("Outlook.Application") '' Get the collection of selected objects. Set objSelection = objOL.ActiveExplorer.Selection '' Set the Attachment folder. strFolderpath = "F:/SkyDrive/Attachments/" '' Check each selected item for attachments. If attachments exist, '' save them to the strFolderPath folder and strip them from the item. For Each objMsg In objSelection '' This code only strips attachments from mail items. '' If objMsg.class=olMail Then '' Get the Attachments collection of the item. Set objAttachments = objMsg.Attachments lngCount = objAttachments.Count strDeletedFiles = "" If lngCount > 0 Then '' We need to use a count down loop for removing items '' from a collection. Otherwise, the loop counter gets '' confused and only every other item is removed. Set fs = New FileSystemObject For i = lngCount To 1 Step -1 '' Save attachment before deleting from item. '' Get the file name. strFile = Left(objAttachments.Item(i).FileName, Len(objAttachments.Item(i).FileName) - 4) + "_" + Right("00" + Trim(Str$(Day(Now))), 2) + "_" + Right("00" + Trim(Str$(Month(Now))), 2) + "_" + Right("0000" + Trim(Str$(Year(Now))), 4) + "_" + Right("00" + Trim(Str$(Hour(Now))), 2) + "_" + Right("00" + Trim(Str$(Minute(Now))), 2) + "_" + Right("00" + Trim(Str$(Second(Now))), 2) + Right((objAttachments.Item(i).FileName), 4) '' Combine with the path to the Temp folder. strFile = strFolderpath & strFile '' Save the attachment as a file. objAttachments.Item(i).SaveAsFile strFile '' Delete the attachment. objAttachments.Item(i).Delete ''write the save as path to a string to add to the message ''check for html and use html tags in link If objMsg.BodyFormat <> olFormatHTML Then strDeletedFiles = strDeletedFiles & vbCrLf & "<file://" & strFile & ">" Else strDeletedFiles = strDeletedFiles & "<br>" & "<a href=''file://" & _ strFile & "''>" & strFile & "</a>" End If ''Use the MsgBox command to troubleshoot. Remove it from the final code. ''MsgBox strDeletedFiles Next i '' Adds the filename string to the message body and save it '' Check for HTML body If objMsg.BodyFormat <> olFormatHTML Then objMsg.Body = vbCrLf & "The file(s) were saved to " & strDeletedFiles & vbCrLf & objMsg.Body Else objMsg.HTMLBody = "<p>" & "The file(s) were saved to " & strDeletedFiles & "</p>" & objMsg.HTMLBody End If objMsg.Save End If Next ExitSub: Set objAttachments = Nothing Set objMsg = Nothing Set objSelection = Nothing Set objOL = Nothing End Sub

Su pregunta tiene 2 tareas para realizar. Primero para extraer los archivos adjuntos de correo electrónico a una carpeta y guardarlos o cambiarles el nombre con un nombre específico.

Si su búsqueda se puede dividir en 2 búsquedas, obtendrá más visitas. Podría referirme a una página que explica cómo guardar el archivo adjunto en una carpeta del sistema < Enlace para la página para guardar archivos adjuntos en una carpeta >.

Por favor, publique cualquier página o código si ha encontrado que quiere guardar el archivo adjunto con un nombre específico.

Vea la propiedad ReceivedTime

http://msdn.microsoft.com/en-us/library/office/aa171873(v=office.11).aspx

Agregó otro / al final de C:/Temp/ en la línea SaveAs File . Podría ser un problema Haga una prueba primero antes de agregar un separador de ruta.

dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm") saveFolder = "C:/Temp"

No ha configurado objAtt así que no hay necesidad de " Set objAtt = Nothing ". Si lo hubiera, sería justo antes de que End Sub no esté en el ciclo.

Public Sub saveAttachtoDisk (itm As Outlook.MailItem) Dim objAtt As Outlook.Attachment Dim saveFolder As String Dim dateFormat dateFormat = Format(itm.ReceivedTime, "yyyy-mm-dd H-mm") saveFolder = "C:/Temp" For Each objAtt In itm.Attachments objAtt.SaveAsFile saveFolder & "/" & dateFormat & objAtt.DisplayName Next End Sub

Re: Funcionó el primer día que empecé a retocar, pero después de eso dejó de guardar archivos.

Esto generalmente se debe a la configuración de seguridad. Es un conjunto de "trampas" para que los usuarios primerizos permitan macros y luego se los lleven. http://www.slipstick.com/outlook-developer/how-to-use-outlooks-vba-editor/

Public Sub Extract_Outlook_Email_Attachments() Dim OutlookOpened As Boolean Dim outApp As Outlook.Application Dim outNs As Outlook.Namespace Dim outFolder As Outlook.MAPIFolder Dim outAttachment As Outlook.Attachment Dim outItem As Object Dim saveFolder As String Dim outMailItem As Outlook.MailItem Dim inputDate As String, subjectFilter As String saveFolder = "Y:/Wingman" '' THIS IS WHERE YOU WANT TO SAVE THE ATTACHMENT TO If Right(saveFolder, 1) <> "/" Then saveFolder = saveFolder & "/" subjectFilter = ("Daily Operations Custom All Req Statuses Report") '' THIS IS WHERE YOU PLACE THE EMAIL SUBJECT FOR THE CODE TO FIND OutlookOpened = False On Error Resume Next Set outApp = GetObject(, "Outlook.Application") If Err.Number <> 0 Then Set outApp = New Outlook.Application OutlookOpened = True End If On Error GoTo 0 If outApp Is Nothing Then MsgBox "Cannot start Outlook.", vbExclamation Exit Sub End If Set outNs = outApp.GetNamespace("MAPI") Set outFolder = outNs.GetDefaultFolder(olFolderInbox) If Not outFolder Is Nothing Then For Each outItem In outFolder.Items If outItem.Class = Outlook.OlObjectClass.olMail Then Set outMailItem = outItem If InStr(1, outMailItem.Subject, "subjectFilter") > 0 Then For Each outAttachment In outMailItem.Attachments outAttachment.SaveAsFile saveFolder & outAttachment.filename Set outAttachment = Nothing Next End If End If Next End If If OutlookOpened Then outApp.Quit Set outApp = Nothing End Sub