Сохранение вложений .XLSX из Outlook 2010 с VBA - PullRequest
Новая
       8

Сохранение вложений .XLSX из Outlook 2010 с VBA

2 голосов
/ 25 февраля 2012

Мы используем Outlook 2010 и получаем электронные письма с вложениями Excel.Мы вручную сохраняем вложение в подпапке, которую создаем в папке подразделения на сетевом диске.

Что мне интересно, так это возможность

  1. Использовать кодчтобы проверить входящие электронные письма, чтобы увидеть, есть ли у них вложение,
  2. Затем проверьте вложение, чтобы увидеть, является ли это .XLSX,
  3. Если так, откройте вложение, проверьте значение определенной ячейки,
  4. затем сохраните имя учетной записи и номер учетной записи в виде строки и переменной
  5. , а затем используйте их для создания подпапок в соответствующем каталоге Windows.

** Я забыл опубликовать, что я сделал до сих пор.Я полагаю, что Бретт ответил на мой вопрос, но, возможно, кто-то еще сможет использовать его фрагменты.

Private Sub cmdConnectToOutlook_Click()
Dim appOutlook As Outlook.Application
Dim ns As Outlook.Namespace
Dim inbox As Outlook.MAPIFolder
Dim item As Object
Dim atmt As Outlook.Attachment
Dim filename As String
Dim i As Integer

Set appOutlook = GetObject(, "Outlook.Application")
Set ns = appOutlook.GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
i = 0 

If inbox.Items.Count = 0 Then
    MsgBox "There are no messages in the Inbox.", vbInformation, _
           "Nothing Found"
    Exit Sub
End If

For Each item In inbox.Items
  For Each atmt In item.Attachments

    If Right(atmt.filename, 4) = "xlsx" Then
        filename = "\\temp\" & atmt.filename
        atmt.SaveAsFile filename
       i = i + 1
    End If

  Next atmt
Next item

MsgBox "Attachments have been saved.", vbInformation, "Finished"

Set atmt = Nothing
Set item = Nothing
Set ns = Nothing

End Sub

1 Ответ

3 голосов
/ 25 февраля 2012

Сказав, что это долго, это один из способов сделать это.Мой код из Код VBA для сохранения вложения (файла Excel) из электронного письма Outlook, которое было в другом письме в качестве вложения , также может представлять интерес

Вам потребуется обновить путь к файлуи диапазон ячеек от файла, который вы открываете

В моем тестировании я отправил себе письмо с файлом PDF и книгой Excel с надписью "bob" в A1 на первом листе

Приведенный ниже код нашел файл Excel, сохранил его, открыл его, создал каталог c:\temp\bob, а затем убил сохраненный файл 

Private Sub Application_NewMailEx _
    (ByVal EntryIDCollection As String)

'Uses the new mail techniquer from http://www.outlookcode.com/article.aspx?id=62

Dim arr() As String
Dim lngCnt As Long
Dim olAtt As Attachment
Dim strFolder As String
Dim strFileName As String
Dim strNewFolder
Dim olns As Outlook.NameSpace
Dim olItem As MailItem
Dim objExcel As Object
Dim objWB As Object

'Open Excel in the background
Set objExcel = CreateObject("excel.application")

'Set working folder
strFolder = "c:\temp"

On Error Resume Next
Set olns = Application.Session
arr = Split(EntryIDCollection, ",")
On Error GoTo 0

For lngCnt = 0 To UBound(arr)
    Set olItem = olns.GetItemFromID(arr(lngCnt))
    'Check new item is a mail message
    If olItem.Class = olMail Then
        'Force code to count attachments
        DoEvents
        For Each olAtt In olItem.Attachments
            'Check attachments have at least 5 characters before matching a ".xlsx" string
            If Len(olAtt.FileName) >= 5 Then
                If Right$(olAtt.FileName, 5) = ".xlsx" Then
                    strFileName = strFolder & "\" & olAtt.FileName
                    'Save xl attachemnt to working folder
                    olAtt.SaveAsFile strFileName
                    On Error Resume Next
                    'Open excel workbook and make a sub directory in the working folder with the value from A1 of the first sheet
                    Set objWB = objExcel.Workbooks.Open(strFileName)
                    MkDir strFolder & "\" & objWB.sheets(1).Range("A1")
                    'Close the xl file
                    objWB.Close False
                    'Delete the saved attachment
                    Kill strFileName
                    On Error Goto 0
                End If
            End If
        Next
    End If
Next
'tidy up
Set olns = Nothing
Set olItem = Nothing
objExcel.Quit
Set objExcel = Nothing
End Sub
...