2016-05-20 10 views
1

В настоящее время мой код, указанный ниже, скопирует информацию о телеобслуживании из входящего письма и откройте назначенный лист Excel и скопирует содержимое на лист Excel и закроет его. Я также хотел бы сохранить вложения от входящей почты на указанный путь: C: \ Users \ ltorres \ Desktop \ ProjectsАвтоматически загружать и сохранять вложение с помощью электронной почты

Я пробовал это, но этот код не будет включать в себя внешний вид. Я бы запустить его с первенствует


Public Sub saveAttachtoDisk (itm As Outlook.MailItem) 
    Dim objAtt As Outlook.Attachment 
    Dim saveFolder As String 
    Dim dateFormat As String 
    saveFolder = "C:\Users\ltorres\Desktop\Projects" 
    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 

Const xlUp As Long = -4162 

Sub ExportToExcel(MyMail As MailItem) 
    Dim strID As String, olNS As Outlook.NameSpace 
    Dim olMail As Outlook.MailItem 
    Dim strFileName As String 

    '~~> Excel Variables 
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object 
    Dim lRow As Long 

    strID = MyMail.EntryID 
    Set olNS = Application.GetNamespace("MAPI") 
    Set olMail = olNS.GetItemFromID(strID) 

    '~~> Establish an EXCEL application object 
    On Error Resume Next 
    Set oXLApp = GetObject(, "Excel.Application") 

    '~~> If not found then create new instance 
    If Err.Number <> 0 Then 
     Set oXLApp = CreateObject("Excel.Application") 
    End If 
    Err.Clear 
    On Error GoTo 0 

    '~~> Show Excel 
    oXLApp.Visible = True 

    '~~> Open the relevant file 
    Set oXLwb = oXLApp.Workbooks.Open("C:\Users\ltorres\Desktop\Projects\Project 2\TemplateFinal\lighting.xlsm") 

    '~~> Set the relevant output sheet. Change as applicable 
    Set oXLws = oXLwb.Sheets("Multiplier") 

    lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1 

    '~~> Write to outlook 
         With oXLws 
        lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 
        Dim MyAr() As String 
        MyAr = Split(olMail.Body, vbCrLf) 
        For i = LBound(MyAr) To UBound(MyAr) 
         .Range("A" & lRow).Value = MyAr(i) 
         lRow = lRow + 1 
        Next i 
          ' 
         End With 

    '~~> Close and Clean up Excel 
    oXLwb.Close (True) 
    oXLApp.Quit 
    Set oXLws = Nothing 
    Set oXLwb = Nothing 
    Set oXLApp = Nothing 

    Set olMail = Nothing 
    Set olNS = Nothing 
End Sub 
+0

Ничего из [этих результатов] (https://www.google.com/search?q=vba+save+outlook+attachment&oq=VBA+save+outlook+&aqs=chrome.0.0j69i57j0l4.2880j0j1&sourceid=chrome&ie= UTF-8) помочь? Что вы пробовали? – BruceWayne

+0

@BruceWayne посмотрите пожалуйста reedited post. Как уже упоминалось, этот код должен работать в excel. Я хотел бы, чтобы Outlook автоматически обнаруживал новую входящую электронную почту с вложениями и сохранял их на пути – Luis

+1

«Он должен быть запущен в Excel ... Я бы хотел, чтобы Outlook автоматически обнаруживал ...», тогда не нужно было бы код? Почему вы думаете, что это должно запускаться из Excel? (Я не использовал Outlook/VBA, так любопытно) – BruceWayne

ответ

0

Попробуй так ...

Update SaveFolder = "c:\temp\" и Workbooks.Open("C:\Temp\Book1.xlsx")

Tes Тэд на Outlook, 2010

Public Sub SaveAtmt_ExportToExcel(Item As Outlook.MailItem) 
    Dim Atmt As Outlook.Attachment 
    Dim SaveFolder As String 
    Dim DateFormat As String 

    Dim strID As String, olNS As Outlook.NameSpace 
    Dim olMail As Outlook.MailItem 
    Dim strFileName As String 

    '~~> Excel Variables 
    Dim oXLApp As Object, oXLwb As Object, oXLws As Object 
    Dim lRow As Long 
    Dim i As Long 

    SaveFolder = "c:\temp\" 
    DateFormat = Format(Now, "yyyy-mm-dd H mm") 

    For Each Atmt In Item.Attachments 
     Atmt.SaveAsFile SaveFolder & "\" & DateFormat & " " & Atmt.DisplayName 
    Next 


    strID = Item.EntryID 
    Set olNS = Application.GetNamespace("MAPI") 
    Set olMail = olNS.GetItemFromID(strID) 

    '~~> Establish an EXCEL application object 
    On Error Resume Next 
    Set oXLApp = GetObject(, "Excel.Application") 

    '~~> If not found then create new instance 
    If Err.Number <> 0 Then 
     Set oXLApp = CreateObject("Excel.Application") 
    End If 
    Err.Clear 
    On Error GoTo 0 

    '~~> Show Excel 
    oXLApp.Visible = True 

    '~~> Open the relevant file 
    Set oXLwb = oXLApp.Workbooks.Open("C:\Temp\Book1.xlsx") 

    '~~> Set the relevant output sheet. Change as applicable 
    Set oXLws = oXLwb.Sheets("Multiplier") 

    lRow = oXLws.Range("A" & oXLws.Rows.Count).End(xlUp).Row + 1 

    '~~> Write to outlook 
    With oXLws 

     lRow = .Range("A" & .Rows.Count).End(xlUp).Row + 1 

     Dim MyAr() As String 

     MyAr = Split(olMail.body, vbCrLf) 

     For i = LBound(MyAr) To UBound(MyAr) 
      .Range("A" & lRow).Value = MyAr(i) 
      lRow = lRow + 1 
     Next i 
     ' 
    End With 

    '~~> Close and Clean 
    oXLwb.Close (True) 
    oXLApp.Quit 

    Set oXLws = Nothing 
    Set oXLwb = Nothing 
    Set oXLApp = Nothing 
    Set olMail = Nothing 
    Set olNS = Nothing 
    Set Atmt = Nothing 
End Sub 
1

Чтобы добавить @ Om3r ответ, вы можете добавить этот код (непроверенные) к ThisOutlookSession модуля:

Private WithEvents objNewMailItems As Outlook.Items 
Dim WithEvents TargetFolderItems As Items 

Private Sub Application_Startup() 

    Dim ns As Outlook.NameSpace 

    Set ns = Application.GetNamespace("MAPI") 
    'Update to the correct Outlook folder. 
    Set TargetFolderItems = ns.Folders.item("Mailbox - Luis") _ 
           .Folders.item("Inbox") _ 
           .Folders.item("Lighting Emails").Items 

End Sub 

Sub TargetFolderItems_ItemAdd(ByVal item As Object) 
    SaveAtmt_ExportToExcel item 
End Sub 

Это будет смотреть папку освещения электронных писем (или любой другой папке вы выбираете) и выполните процедуру SaveAtmt_ExportToExcel всякий раз, когда приходит электронное письмо в эту папку.

Это означает, что Excel откроется и закроется для каждого письма. Он также прервет все остальное, что вы делаете, чтобы открыть Excel и выполнить - так что, вероятно, захочет обновиться, поэтому он только откроет Excel один раз и запустит правило Outlook, чтобы разместить электронные письма в правильной папке один раз в день, а не всегда.

Смежные вопросы