Страницы: 1
RSS
Сохранение вложений из нескольких писем (Outlook), batch attachments saving
 
День добрый. Использую вот такой код для сохранения вложений из нескольких выделенных писем сразу (нужные рассылки и всё такое).
Скрытый текст

Из-за того, что Application.FileDialog не хочет работать в Outlook, приходится вызывать диалоговое окно Word (он быстрее грузится у меня, чем Excel :) )
Но диалоговое окно выбора папки сохранения появляется у меня в фоновом режиме, т.е. "за окном" Outlook.
Как его заставить появляться впереди? что-то туплю. Причем желательно не в режиме system.modal, т.к. иногда нужно проверить, правильно ли выбран каталог, при помощи проводника.
F1 творит чудеса
 
Я пользуюсь shell
Код
Sub test()
Dim Ws As Object, Fld As Object
On Error Resume Next
Set Ws = CreateObject("Shell.application")
Set Fld = Ws.browseforfolder(0, "Выбор папки", 0, "c:\")
If Not Err.Number = 91 Then MsgBox Fld.self.Path
Set Ws = Nothing : Set Fld = Nothing
End Sub
 
Спасибо за наводку, так сильно быстрее и правильнее!!!
Только заменил "c:" на "ssfDRIVES" - привычнее и нет ограничения сверху.
Итоговый код
F1 творит чудеса
 
Этот параметр можно вообще не использовать
Код
Set Fld = Ws.browseforfolder(0, "Select path to save attachments:", 0)
 
Друзья, нашел вот такой код для этой же цели
Код
Dim myobj As Object
Dim att As Attachment
For Each myobj In Application.ActiveExplorer.Selection
If myobj.Class = olMail Then
For Each att In myobj.Attachments
att.SaveAsFile "D:\Attachments\" + att.FileName
Next
End If
Next
Тоже хорошо и быстро работает, но...

Можете подсказать как модифицировать этот код?
Много писем от одного отправителя. Вложение с одним и тем же называнием. Но тема письма всегда разная.
Как можно этот скрипт изменить так что бы он сохранял вложения, переименовывая его по называнию темы письма?

Очень выручите от обезьяньего труда. Спасибо!
 
Код
att.SaveAsFile "D:\Attachments" + myobj.Subject & ".тут расширение файла"


всякие проверки на правильность написания имени файла и его расширения на Вашей совести.
 
Возможно ли через макрос открыть папку, выбранную для сохранения файлов?
 
Добрый день
Максим Зеленский, спасибо за код
Вложения выгружает, но если у вложений одинаковое имя, то сохраняется только одно, остальные нет.

Подскажите пожалуйста, как изменить код чтобы в имени выгружаемых вложений перед расширением (".xls" или другие) стояла дата присланного письма:

Код
Sub SaveAttmnts()
Dim myobj As Object
Dim att As Attachment
Dim sPath As String
Dim Ws As Object, Fld As Object
On Error Resume Next
Set Ws = CreateObject("Shell.application")
Set Fld = Ws.BrowseForFolder(0, "Select path to save attachments:", 0, "ssfDRIVES")
If Not Err.Number = 91 Then
    sPath = Fld.self.Path
Else
    Exit Sub
End If
Set Ws = Nothing: Set Fld = Nothing
For Each myobj In Application.ActiveExplorer.Selection
    If myobj.Class = olMail Then
    For Each att In myobj.Attachments
        att.SaveAsFile sPath & "\" & att.FileName
    Next
    End If
Next
MsgBox "Attachments saved to " & sPath, vbOKOnly + vbInformation + vbSystemModal
End Sub
Изменено: viktor.petryuk - 28.02.2018 13:05:31
 
Попробуйте пока так:
Код
Sub SaveAttmnts()
  Dim a As Variant
  Dim myobj As Object
  Dim att As Attachment
  Static sPath As String
  Dim Ws As Object, Fld As Object
  Dim i As Long, j As Long
  On Error Resume Next
  Set Ws = CreateObject("Shell.application")
  Set Fld = Ws.BrowseForFolder(0, "Select path to save attachments:", 0, sPath & "\")
  If Not Err.number = 91 Then
    sPath = Fld.self.PATH
    If Len(Fld.self.PATH) = 0 Then Exit Sub
  Else
    Exit Sub
  End If
  Set Ws = Nothing: Set Fld = Nothing
  For Each myobj In Application.ActiveExplorer.Selection
    If myobj.Class = olMail Then
      j = 0
      For Each att In myobj.Attachments
        j = j + 1
        a = Split(att.FileName, ".")
        i = UBound(a)
        If i > 0 Then i = i - 1
        a(i) = a(i) & "_" & Format(myobj.ReceivedTime, "yyddmm-hhmmss") & Format(j, "-00")
        att.SaveAsFile sPath & "\" & Join(a, ".")
      Next
    End If
  Next
  MsgBox "Attachments saved to " & sPath, vbOKOnly + vbInformation + vbSystemModal
End Sub
Изменено: ZVI - 01.03.2018 08:47:47
 
ZVI, СПАСИБО ОГРОМНОЕ!!!
:)  Все работает!
 
ZVI, Очень полезная вещь, долго искал. Спасибо!
Подскажите как сделать так, чтобы сохранялись только файлы Excel? Сейчас сохраняет и картинки из подписи:)
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
Dyroff,
Думаю можно так
Код
    For Each att In myobj.Attachments
        j = j + 1
        a = Split(att.Filename, ".")
        i = UBound(a)
        If LCase(Left(a(i), 3)) = "xls" Then
            If i > 0 Then i = i - 1
            a(i) = a(i) & "_" & Format(myobj.ReceivedTime, "yyddmm-hhmmss") & Format(j, "-00")
            att.SaveAsFile sPath & "\" & Join(a, ".")
        End If
      Next


у этой строки    
Код
If LCase(Left(a(i), 3)) = "xls" Then 
масса вариантов, и  если честно , то с учетом того что можно использовать совершенно левое xlsZ например и это может быть совершенно не  Excel файл, лучше сравнивать с конкретным списком,
По вопросам из тем форума, личку не читаю.
 
БМВ, Спасибо Вам:)

Про сравнение списка:
Код
If LCase(Left(a(i), 3)) = "xls"  or=LCase(Left(a(i), 3)) = "xlsx" or LCase(Left(a(i), 3)) = "xlsm" or LCase(Left(a(i), 3)) = "xlsb" Then

так?
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
Dyroff,  нет LCase(Left(a(i), 3)) = "xlsx" никогда не выполнится, так как три символа всегда не равны 4м :-)
Везде LCase(a(i)) =
По вопросам из тем форума, личку не читаю.
 
БМВ, :) Спасибо)
Нужно бежать со всех ног, чтобы только оставаться на месте, а чтобы куда-то попасть, надо бежать как минимум вдвое быстрее!
 
Цитата
БМВ написал:
лучше сравнивать с конкретным списком
Код
  xlsExt = " xla xls xlt xlam xlsb xlsm xlsx xltm xltx "
  If InStr(1, xlsExt, " " & a(i) & " ", vbTextCompare) > 0 Then
Владимир
 
А у меня не пашет((( Где косячу, подскажите!!!
Изменено: dimon_ruki_nozhnicy - 07.04.2020 15:44:46
 
Надо подключить библиотеку.
Меню Tools>References поставить галочку Microsoft Outlook xx.xx Type Library.
 
Цитата
МатросНаЗебре написал:
Надо подключить библиотеку.Меню Tools>References поставить галочку Microsoft Outlook xx.xx Type Library.
Спасибо! Макрос сработал, только в указанную папку ничего не переместилось. Объясните дурачку механику поподробнее, пожалуйста))
Не понимаю, как указать из каких писем нужно взять вложения.

UPD: Всем спасибо! Разобрался сам)))) Оказывается, когда никто не отвечает пару дней, в голову начинают приходить полезные идеи.
Изменено: dimon_ruki_nozhnicy - 09.04.2020 10:51:09 (нашел решение)
Страницы: 1
Наверх