[internetbeyi]

Merhaba,
Outlook ta taslak klasöründe bulunan mailleri göndermek için aşağıdaki Makro kodunu kullanıyorum.
Yapmak istediğim Taslak klasöründeki mailleri gönderirken belirli bir süre aralık vermesi.
Yani mailler arasında 5-10 saniye bekleme yaparak gönderim yapmak istiyorum.
Taslak kutumda bazen 1000 in üzerinde mail bulunabiliyor.


Aşağıdaki kodda değişiklik yaparak bu işlemi halledebilir miyim?
Yardımlarınız için şimdiden teşekürler.

Kod: Tümünü seç

Sub SendAllDraftEmails()

  Dim objDrafts As Outlook.Items
  Dim objDraft As Object
  Dim strPrompt As String
  Dim nResponse As Integer
  Dim i As Long
  Dim merror As Integer, Gcount As Integer

  On Error GoTo err_handle

  Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
  Gcount = objDrafts.Count

  If objDrafts.Count > o Then
      strPrompt = "Are you sure you want to send out all the drafts?"
      nResponse = MsgBox(strPrompt, vbQuestion + vbYesNo, "Confirm Sending")

      If nResponse = vbYes Then
            For i = objDrafts.Count To 1 Step -1
                  objDrafts.Item(i).Send
             Next
      End If

      If merror > 0 And merror = Gcount Then
             MsgBox "No Draft Emails Sent!", vbCritical, "Email Sending Errors!"
      ElseIf merror > 0 And merror < Gcount Then
             MsgBox "Some Draft Emails were sent - " & Trim(Str(merror)) & " emails were not sent", vbCritical, "Email Sending Errors!"
      Else
             MsgBox "All Draft Emails Sent!", vbInformation, "Email Sending"
      End If
  Else
      MsgBox "No Draft Emails Found!", vbExclamation, "No Draft Emails Found"
  End If

  Exit Sub

err_handle:

  If Err = "-2147467259" Then
      MsgBox "There must be at least one email address or contact group in the TO, CC or BCC fields" & vbCrLf & "Fix it and re-run your emails", vbExclamation, "Error in Email Address!"
      merror = 1 + merror
      Resume Next
  End If

End Sub

[Feyzullah]

objDrafts.Item(i).Send
             Next

Kodlarınızın arasındaki Next kodunun üstüne Application.Wait (Now + TimeValue("0:00:05")) kodunu yazınız.

İyi çalışmalar.

[internetbeyi]

Merhaba,

İlginiz için teşekkür ederim. Verdiğiniz kodu söylediğiniz yere ekledim ancak çalışmadı.
Kodu eklemeden önce makroyu çalıştırdığımda taslak kutusundaki tüm iletileri gönderiyordu.
Ekledikten sonra sadece 1 tane iletiyi gönderiyor ve duruyor.
Sanırım döngüyü sağlayamadı.

Konu günceldir, yardımcı olabilecek arkadaşlara şimdiden teşekkürler.

[Feyzullah]

Hocam, bir de For i = objDrafts.Count To 1 Step -1 bu kodun altına yazıp deneyin. Ben döngülerde bunu kullanıyorum ve sağlıklı çalışıyor.

Kod: Tümünü seç

Application.Wait (Now + TimeValue("0:00:05"))

[internetbeyi]

Malesef,
Hiç tepki vermedi , hatta ilk maili dahi göndermedi.
Yinede ilginiz için teşekkür ederim.

[Enes Recep BAĞ]

Kod: Tümünü seç

Sub SendAllDraftEmails()

  Dim objDrafts As Outlook.Items
  Dim objDraft As Object
  Dim strPrompt As String
  Dim nResponse As Integer
  Dim i As Long
  Dim merror As Integer, Gcount As Integer

  On Error GoTo err_handle

  Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
  Gcount = objDrafts.Count

  If objDrafts.Count > o Then
      strPrompt = "Are you sure you want to send out all the drafts?"
      nResponse = MsgBox(strPrompt, vbQuestion + vbYesNo, "Confirm Sending")

      If nResponse = vbYes Then
            For i = objDrafts.Count To 1 Step -1
                  objDrafts.Item(i).Send
                  Application.Wait (Now + TimeValue("0:00:05"))
             Next
      End If

      If merror > 0 And merror = Gcount Then
             MsgBox "No Draft Emails Sent!", vbCritical, "Email Sending Errors!"
      ElseIf merror > 0 And merror < Gcount Then
             MsgBox "Some Draft Emails were sent - " & Trim(Str(merror)) & " emails were not sent", vbCritical, "Email Sending Errors!"
      Else
             MsgBox "All Draft Emails Sent!", vbInformation, "Email Sending"
      End If
  Else
      MsgBox "No Draft Emails Found!", vbExclamation, "No Draft Emails Found"
  End If

  Exit Sub

err_handle:

  If Err = "-2147467259" Then
      MsgBox "There must be at least one email address or contact group in the TO, CC or BCC fields" & vbCrLf & "Fix it and re-run your emails", vbExclamation, "Error in Email Address!"
      merror = 1 + merror
      Resume Next
  End If

End Sub


[internetbeyi]

Enes Bey ilginiz için teşekkür ederim. Verdiğiniz kodu direkt olarak (kopyala-yapıştır) uyguladığımda ilk maili gönderiyor ve daha sonra herhangi bir işlem yapmıyor.

Belki outlook sürümümden dolayı çalışmıyor olabilir.

Alternatif olarak ilk kodda bazı değişiklikler yaparak sonuca ulaştım sayılır. Outlookun bir süre donmuş gibi gözükmesine rağmen maillerin arasına eklediğim bekleme süresi işlevini görüyor.

Kod: Tümünü seç

[color=#FF0000]Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)[/color]

Sub SendAllDraftEmails()

  Dim objDrafts As Outlook.Items
  Dim objDraft As Object
  Dim strPrompt As String
  Dim nResponse As Integer
  Dim i As Long
  Dim merror As Integer, Gcount As Integer

  On Error GoTo err_handle

  Set objDrafts = Outlook.Application.Session.GetDefaultFolder(olFolderDrafts).Items
  Gcount = objDrafts.Count

  If objDrafts.Count > o Then
      strPrompt = "Are you sure you want to send out all the drafts?"
      nResponse = MsgBox(strPrompt, vbQuestion + vbYesNo, "Confirm Sending")

      If nResponse = vbYes Then
            For i = objDrafts.Count To 1 Step -1
                  objDrafts.Item(i).Send
             [color=#FF00FF]Sleep 10000[/color]
             Next
      End If

      If merror > 0 And merror = Gcount Then
             MsgBox "No Draft Emails Sent!", vbCritical, "Email Sending Errors!"
      ElseIf merror > 0 And merror < Gcount Then
             MsgBox "Some Draft Emails were sent - " & Trim(Str(merror)) & " emails were not sent", vbCritical, "Email Sending Errors!"
      Else
             MsgBox "All Draft Emails Sent!", vbInformation, "Email Sending"
      End If
  Else
      MsgBox "No Draft Emails Found!", vbExclamation, "No Draft Emails Found"
  End If

  Exit Sub

err_handle:

  If Err = "-2147467259" Then
      MsgBox "There must be at least one email address or contact group in the TO, CC or BCC fields" & vbCrLf & "Fix it and re-run your emails", vbExclamation, "Error in Email Address!"
      merror = 1 + merror
      Resume Next
  End If

End Sub

İlginiz için teşekkür ederim.