• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

For Döngüsünde Hata

B

baysevimli

Katılım
13 Eylül 2015
Mesajlar
201
Excel Vers. ve Dili
2010 VBA
Değerli Arkadaşlar Merhaba,

Excelde seçili alanımı mailin gövde kısmına yapıştıran bir otomatik mail kodum var. Ben For döngüsü ile 37 kişiye ayrı ayrı mail açıp göndermesi için bişeyler yaptım. Ancak, aşağıdaki kodumu çalıştırdığımda 37 mailin bazılarının gövdesine excelimdeki "A1:"E12" alanımı almıyor. Bazılarına ise aynı gövdeyi birden çok kez kopyalıyor. Bi yerde hata yapıyorum ama çözemedim. yardımcı olabilir misiniz ?


Kod: 
Private Sub CommandButton1_Click()
If (tarih.Value = "") Or (tarih.Value <> Format(tarih, "dd.mm.yyyy")) Then
MsgBox " Tarih Formatında Bir HATA Tespit Edildi. Lütfen Kontrol Ediniz!"
tarih.Value = ""
Else
    Dim rng As Range
    Dim SKK As Worksheet: Set SKK = Sheets("Karar Şablon")
    Dim SKKM As Worksheet: Set SKKM = Sheets("İK-YK Karar")
    Dim OutApp As Object
    Dim OutMail As Object
      
    Set rng = Nothing
            For i = 1 To 37
            If Me.Controls("bsk" & i).Value = True Then
                j = i + 3
                On Error Resume Next
                Set rng = SKK.Range("A1:E12").Copy
                 On Error GoTo 0

                    With Application
                    .EnableEvents = False
                    .ScreenUpdating = False
                     End With

                 Set OutApp = CreateObject("Outlook.Application")
                 Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next
                     With OutMail
                    .sentonbehalfofname = "GSKT@BB.COM"
                    .To = SKKM.Range("C" & j).Value
                    '.CC = ""
                    '.BCC = ""
                    .Subject = "Bildiri"
                    .Display
                     DoEvents
                     SendKeys "^v", True
                     End With
                 On Error GoTo 0
          
                With Application
                .EnableEvents = True
                .ScreenUpdating = True
                 End With

                Set OutMail = Nothing
                Set OutApp = Nothing
            End If
        Next i
            If j = 0 Then MsgBox "Herhangi bir Kutu Seçmediniz ! "
            End If
End Sub

Private Sub tarih_Change()
Dim SKK As Worksheet: Set SKK = Sheets("İK-YK Karar")
SKK.Range("K2") = Format(tarih, "dd.mm.yyyy")
End Sub
 
. . .

.Display işleminden sonra mail gövde ekranın açılması için ve
yapıştırma işleminden sonra programın nefes almasına izin verin.
Aşağıdaki bekletme kodunu 2 alanada ilave edin. Saniyeyi bilgisayar performansına göre değiştirebilirsiniz.

Kod: 
Application.Wait (Now() + TimeValue("00:00:02")) [COLOR="Green"]' 2 SANİYE[/COLOR]


Aynı alanı sürekli kopyalamaya gerek var mı. Bir kez koplayayınca hepsinde yapıştırmaya izin verecektir. Deneyiniz.
. . .
 
Emir bey günaydın,

Paylaştığınız kodlarıda ilave ederek aşağıdaki gibi test ettim. Ancak, 37 mailden 4 tanesi ile test ettim. İlk 3 mailimi gövdesine yapıştırmadı, en son açtığı mailin gövdesine 4 defa kopyaladı. Başka bir yönetimi var mıdır ?


Kod: 
Private Sub CommandButton1_Click()
If (tarih.Value = "") Or (tarih.Value <> Format(tarih, "dd.mm.yyyy")) Then
MsgBox " Tarih Formatında Bir HATA Tespit Edildi. Lütfen Kontrol Ediniz!"
tarih.Value = ""
Else
    Dim rng As Range
    Dim SKK As Worksheet: Set SKK = Sheets("Karar Şablon")
    Dim SKKM As Worksheet: Set SKKM = Sheets("İK-YK Karar")
    Dim OutApp As Object
    Dim OutMail As Object
      
    Set rng = Nothing
            For i = 1 To 37
            If Me.Controls("bsk" & i).Value = True Then
                j = i + 3
                On Error Resume Next
                Set rng = SKK.Range("A1:E12").Copy
                 On Error GoTo 0

                    With Application
                    .EnableEvents = False
                    .ScreenUpdating = False
                     End With

                 Set OutApp = CreateObject("Outlook.Application")
                 Set OutMail = OutApp.CreateItem(0)

                On Error Resume Next
                     With OutMail
                    .sentonbehalfofname = "GSKT@BB.COM"
                    .To = SKKM.Range("C" & j).Value
                    '.CC = ""
                    '.BCC = ""
                    .Subject = "Bildiri"
                    .Display
                     Application.Wait (Now() + TimeValue("00:00:02")) ' 2 SANİYE
                     DoEvents
                     SendKeys "^v", True
                     Application.Wait (Now() + TimeValue("00:00:02")) ' 2 SANİYE
                     End With
                 On Error GoTo 0
          
                With Application
                .EnableEvents = True
                .ScreenUpdating = True
                 End With

                Set OutMail = Nothing
                Set OutApp = Nothing
            End If
        Next i
            If j = 0 Then MsgBox "Herhangi bir Kutu Seçmediniz ! "
            End If
End Sub

Private Sub tarih_Change()
Dim SKK As Worksheet: Set SKK = Sheets("İK-YK Karar")
SKK.Range("K2") = Format(tarih, "dd.mm.yyyy")
End Sub
 
Emir bey merhaba,

Örnek dosyam ektedir.

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

Ekli dosyalar

. . .

İnceledim. İşlem userform ile başladığı için aktif pencere kısmında sorun oluyor.
Şimdilik bir çözüm üretemedim.

. . .
 
Çözüm için bekleyeyim mi ? Konu ile ilgilenmeye devam ediyor musunuz acaba?
 
. . .

Aklıma gelen çözümleri denedim. Sonuç alamadım.
Mail gövdesinde resim olarak göndermeyi önerebilirim veya ekinde pdf olarak vs...

. . .
 
Emir bey mail gövdesinde taslağın içine manunel metin yapıştırmam gerekeceğinden resim olarak almak sonuç vermez bana.
 
Yardımcı olabilecek ?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst