Otomatik Mail Kodunda Hata

[baysevimli]

Korhan Bey,

Özür dilerim sorunumu anlatamadım ben. Tekrar özetlemeye çalışayım.

Ekli dosyamdaki excelde A1 ile E16 daki alanı outlook gövdesine alıp gövde kısmında yazan cümledeki tarihide "I2" hücresinden çekmek istiyorum. Mailin konu kısmında ise "Bildiri" yazsın istiyorum.

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

 

[askm]

Aşağıdaki kodlar ile yapabilirsiniz.
Yalnız C içerisine resim diye bir klasör açmanız gerekiyor. (Resmi resim klasörüne alıyor outlook a ekledikten sonra siliyor.)

Sub kod()

Dim S1 As Worksheet: Set S1 = Sheets("Sayfa1")
Dim rng As Range, cht As ChartObject, say As Double, obj As Object
Const strPath As String = "C:\resim\"


With Application
.EnableEvents = False
.ScreenUpdating = False
End With
S1.Select
isim = "mailek_" & Format(Now, "ddmmyyhhmmss")
Set obj = CreateObject("Scripting.FileSystemObject").GetFold er(strPath)
say = obj.Files.Count + 1
Set rng = S1.Range("A1:E16")

rng.CopyPicture xlScreen, xlPicture
Set cht = ActiveSheet.ChartObjects.Add(0, 0, rng.Width + 10, rng.Height + 10)
cht.Chart.Paste
cht.Chart.Export strPath & isim & ".jpg"
cht.Delete
ExitProc:
Set obj = Nothing: Set rng = Nothing: Set cht = Nothing

Dim xlOutlook As Object
Dim xlMail As Object
Set xlOutlook = CreateObject("Outlook.Application")
Set xlMail = xlOutlook.CreateItem(0)
htmlyaz = "<img src=" & strPath & isim & ".jpg" & " alt=''"

With xlMail
.To = ThisWorkbook.Sheets("Sayfa1").Range("h4").Value
.CC = ""
.Subject = Cells(3, "G") & Cells(3, "H")
.HTMLBody = htmlyaz
.Importance = 2
.Save
.Display
'.Send
End With

Set xlMail = Nothing
Set xlOutlook = Nothing
Kill strPath & isim & ".jpg"

With Application
.EnableEvents = True
.ScreenUpdating = True
End With
End Sub

 

[baysevimli]

Askm merhaba C diskine "resim" diye klasör açarak test ettim. Ancak ekteki hatayı aldım.

 

[askm]

Set obj = CreateObject("Scripting.FileSystemObject").GetFold er(strPath)
kodu aşağıdaki şekilde değiştirin.
Set obj = CreateObject("Scripting.FileSystemObject").GetFolder(strPath)

 

[baysevimli]

aynı kodu paylaşmışsınız galiba. Bi değişiklik göremedim

 

[askm]

Folder kısmı ayrı çıkıyor internetten dolayı fold ile er kısmının aradaki boşluğu silin.

 

[baysevimli]

Askm

Denedim çalıştı belirttiğim alanı gövdeye aldı ama tamamını resim olarak aldı, doğal olarak "Bu alana asd..." diye başlayan gövdemdeki cümleye metin yapıştıramıyorum. Benim amacım o alana metin yapştırıp göndermek.

 

[askm]

Yapmak istediğiniz işlemin örnek bir çalışması olsa daha kolay işlem yaparız. O alana ne yazmak istiyorsanız ona göre önce o kelimeleri yazdırır ondan sonra kodu çalıştırırız.
Ya da K sütununa yazmak istediğiniz cümleleri yazarsınız. Bu alana da oradan formülle çekersiniz.

 

[baysevimli]

Şöyle ifade edeyim. A1 ile E16 daki taslak şablonumu alacak. Ben ise "Bilgilerinize arz olunur" cümlesinin altına 6-7 paragraf yazı yapıştırıp göndericem. Yapıştırıp göndereceğim metin yada yazılar sabit değil sürekli değişecek. Dolayısıyla "Bilgilerinize arz olunur" cümlesinin altına metin ekleyebileceğim şekilde almalı. Bunu belki excelde K sütunundan da alabiliriz doğrudur ancak açılan outllok penceresinde yapıştırıp göndermem lazım.Bu şekilde ekran görüntüsü alıyor dolayısıyla içine müdehale edemiyorum.

 

[askm]

Exceli excel olarak outlook a yapıştıran bir kod bilmiyorum. Ya Korhan Beyin sunduğu çözüm ile excelde açılan pencereden düzenleme yapıp gönder yapabilirsiniz. Ya da önce hücreyi değiştirir sonra butonu çalıştırırsınız, outlooka resim olarak ekler. Dediğiniz gibi bir çözüm sunan olursa takipde olacağım.

 

[baysevimli]

askm çok teşekkür ederim ilginize sağolun.

Korhan bey yardımlarınızı bekliyorum.

 

[baysevimli]

Korhan Bey veya yardımcı olabilecek üstadlar konu günceldir.

 

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

Sub Mail_Gonder()
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    Set rng = Range("A1:E16").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
        .To = Cells(4, "H").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 Sub

 

[baysevimli]

Korhan bey şimdi oldu. Çok teşekkür ederim. Eksik olmayın.