Поиск  Пользователи  Правила  Войти
Форумы "Планета Excel" » Вопросы по Microsoft Excel
Страницы: 1
RSS
Закрыть Outlook только при пустой папке "Исходящие"
 
#1
20.01.2020 08:27:56
Доброго здоровья всем :)
Ребят, ну выручайте, пожалуйста!
Есть макрос по отправке писем:
Код
Sub Mail()
Dim i As Long
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
 
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    objOutlookApp.Session.Logon
For i = 1 To 9

Cells(10, 4) = i
ActiveWorkbook.Save

    Set objMail = objOutlookApp.CreateItem(0)  
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub

    sTo = Cells(i, 3) 
    sSubject = "оплата"   
    sAttachment = ActiveWorkbook.FullName

    With objMail
        .To = sTo 
        .Subject = sSubject
         .Attachments.Add sAttachment
        .Send
    End With
    
 Next i

    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True

End Sub

Работает как хотелось вроде бы, но собственно в чём проблема то: задачи создаются, письма всем отправляются, но макрос справляется настолько быстро, что он закрывает в конце аутлук и не все письма уходят адресатам, то есть по факту до конца процедуры успевает отправиться, например, писем 6 из 9, а остальные виснут в исходящих и дожидаются нового сеанса! Приходиться открывать аутлук вручную и дожидаться пока все исходящие разлетятся.

Как же всё таки объяснить ему закрыть приложение только с пустой папкой "исходящие"?
 
 
 
#2
20.01.2020 09:48:50
Видел модификацию этого макроса. Может эта пауза и в Вашем случае поможет.
Код
 With objMail        .To = sTo 
        .Subject = sSubject
         .Attachments.Add sAttachment
        .Send
 End With
 For j = 1 To 100000: DoEvents: Next
 
 
 
#3
20.01.2020 09:55:46
А где в коде закрывается Outlook?
Это?
Код
Set objOutlookApp = Nothing:


Можно паузой сделать, но тут не понятно сколько времени нужно на эту паузу.
Код
Application.Wait Time:=Now + TimeValue("0:00:10")
Изменено: Nordheim - 20.01.2020 09:57:25
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#4
20.01.2020 10:12:02
Ребят, спасибо вам за подсказку с паузой! Да, это хорошее решение, но есть нюанс, и он связан с соединением, то есть можно поставить и 10 секунд, и 20 секунд, но всё равно мысль перепроверить папку не даёт покоя, так как работа предполагает своевременное извещение.
Поэтому проверка на "пустоту" этой папки было бы идеальным решением.
Изменено: Azakia - 20.01.2020 10:15:20
 
 
 
#5
20.01.2020 10:16:01
Можно пойти и "страшным" путем - опрашивать папку Исходящие:
Код
Sub Mail()
    Dim i As Long
    Dim objOutlookApp As Object, objMail As Object
    Dim sTo As String, sSubject As String, sBody As String, sAttachment As String
    Dim oSending As Object
  
    Application.ScreenUpdating = False
    On Error Resume Next
    Set objOutlookApp = GetObject(, "Outlook.Application")
    Err.Clear
    If objOutlookApp Is Nothing Then
        Set objOutlookApp = CreateObject("Outlook.Application")
    End If
    'подключаемся к папке Исходящие
    Set oNSpace = objOutlookApp.GetNamespace("MAPI")
    Set oSending = oNSpace.GetDefaultFolder(4) 'Исходящие

    objOutlookApp.Session.Logon
For i = 1 To 9
 
Cells(10, 4) = i
ActiveWorkbook.Save
 
    Set objMail = objOutlookApp.CreateItem(0)  
    If Err.Number <> 0 Then Set objOutlookApp = Nothing: Set objMail = Nothing: Exit Sub
 
    sTo = Cells(i, 3) 
    sSubject = "оплата"  
    sAttachment = ActiveWorkbook.FullName
 
    With objMail
        .To = sTo 
        .Subject = sSubject
         .Attachments.Add sAttachment
        .Send
    End With
     
 Next i
    do while oSending.Items.Count > 0
        doevents'возможно, имеет смысл сделать какой-то счетчик, чтобы не попасть в бесконечный цикл при отсутствии подключения к Internet
    loop
    Set objOutlookApp = Nothing: Set objMail = Nothing
    Application.ScreenUpdating = True
 
End Sub
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
#6
20.01.2020 10:26:34
Дмитрий(The_Prist) Щербаков, спасибо за решение!
 
 
 
#7
20.01.2020 10:30:21
Код
do while oSending.Items.Count > 0
        doevents'возможно, имеет смысл сделать какой-то счетчик, чтобы не попасть в бесконечный цикл при отсутствии подключения к Internet
loop

Можно счетчик со временем, что бы цыфры запредельные не писать.
Код
    Do While oSending.Items.Count > 0
        i = i + 1
        Application.Wait Time:=Now + TimeValue("0:00:10")
        If i = 15 Then Exit Do
    Loop
"Все гениальное просто, а все простое гениально!!!"
 
 
 
#8
20.01.2020 10:47:30
Не люблю Wait - он поедает ресурсы слишком жирно. Плюс здесь опять же лучше будет по таймеру сравнивать. Что-то вроде:
Код
Dim iTimer
    iTimer = Timer
    Do While oSending.Items.Count > 0
        DoEvents
        If Format((Timer - iTimer) / 86400, "Long time") >= "0:05:00" Then
            Exit Do
        End If
    Loop
"0:05:00" - это пять минут.
Даже самый простой вопрос можно превратить в огромную проблему. Достаточно не уметь формулировать вопросы...
 
 
 
Страницы: 1
Читают тему
Наверх