[yasartoms]

merhaba

bir excelim var ve belli hücrelerde mail adresleri var.

bu mail adreslerine excelldeki belli hücre aralığını alarak mail gövdesine yapıştırıp mail oluşturmasını istiyorum.
ama nedense mail adreslerini hücreden alarak mail yollayamyı beceremedim

kod aşağıda nasıl bir düzenleme yapmalıyım

çalıştırdığımda koddaki bu HTMLBody = RangetoHTML(rng) bunu sarıya boyuyor

[code][/code]
Sub Belirlenen_Hucre_Araligini_Mesaj_Gövdesine_Gonder()
'Office 2000-2010 sürümlerinde çalışır
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
On Error Resume Next
Set rng = Sheets("detay").Range("A1:c19").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = Cells(7, 1)
.CC = Cells(7, 2)
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
.Display 'göndermek için .Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

[Feyzullah]

Konuyu tam anlamadım. Mail adreslerine tek tek döngülü şekilde mi mail atmak istiyorsunuz yoksa cc kısmına toplu mail mi atacaksınız eger cevabınız evet ise aşağıdaki kodu değiştirin ve mail adreslerinin hangi hücre aralığında ise ona göre uyarlayın.

Kod: Tümünü seç

.To =Join(Application.Transpose(Worksheets("TOPLU MAİL").Range("B2:B8").Value), ";")' sayfa adını ve hücre aralığını değiştirin

[yasartoms]

Konuyu tam anlamadım. Mail adreslerine tek tek döngülü şekilde mi mail atmak istiyorsunuz yoksa cc kısmına toplu mail mi atacaksınız eger cevabınız evet ise aşağıdaki kodu değiştirin ve mail adreslerinin hangi hücre aralığında ise ona göre uyarlayın.

Kod: Tümünü seç

.To =Join(Application.Transpose(Worksheets("TOPLU MAİL").Range("B2:B8").Value), ";")' sayfa adını ve hücre aralığını değiştirin

To = g1
.CC = g2
.BCC =
.Subject = g3

olsun istiyorum ama kodu çalıştırdığımda

.HTMLBody = RangetoHTML(rng) bu kodda sarı yanıyor kod çalışmıyor.

[Feyzullah]

RangetoHTML için function modülde yoksa aşağıdaki kodu da çalıştığınız sayfanın makro modülüne yapıştırın.

Kod: Tümünü seç

Function RangetoHTML(rng As Range)
    'Office 2000-2016 sürümlerinde çalışır
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Kopya aralığı ve geçmiş verileri yeni bir çalışma kitabı oluşturamazsınız
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Sayfayı htm dosyası olarak yayınla
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'RangetoHTML içine htm dosyası olan tüm verileri oku
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
     'TempWB'yi kapat
    TempWB.Close savechanges:=False
    'htm dosyası olan bu fonksiyonu sil
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

[yasartoms]

RangetoHTML için function modülde yoksa aşağıdaki kodu da çalıştığınız sayfanın makro modülüne yapıştırın.

Kod: Tümünü seç

Function RangetoHTML(rng As Range)
    'Office 2000-2016 sürümlerinde çalışır
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Kopya aralığı ve geçmiş verileri yeni bir çalışma kitabı oluşturamazsınız
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    'Sayfayı htm dosyası olarak yayınla
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'RangetoHTML içine htm dosyası olan tüm verileri oku
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
     'TempWB'yi kapat
    TempWB.Close savechanges:=False
    'htm dosyası olan bu fonksiyonu sil
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

çok teşekkürler elinize sağlık

[tdemirhan]

Merhaba,

5 dakikalık aralıklar ile yaklaşık 8 saat sorunsuz çalışarak mail gönderen kodlarım, aniden çalışmaz oldu ve mail fonksiyonunun aşağıda ki kısmında hata verip çalışmaz oldu

Kod: Tümünü seç

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)

sebebi ne olabilir?

[tdemirhan]

Merhaba,

5 dakikalık aralıklar ile yaklaşık 8 saat sorunsuz çalışarak mail gönderen kodlarım, aniden çalışmaz oldu ve mail fonksiyonunun aşağıda ki kısmında hata verip çalışmaz oldu

Kod: Tümünü seç

    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)

sebebi ne olabilir?

Bir önceki mesajda bulunan kod satırlarının önüne aşağıdaki kodu ekleyince sorunsuz çalışmaya devam ediyor. Sorun çözüldü.

Kod: Tümünü seç

Application.ReferenceStyle = xlA1