Otomatik Mail Gönderme

aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Merhabalar,

Aşağıdaki kodlarda otomatik mail gönderebiliyorum ancak excelde şeçili alanı kopyalayıp mail sayfasına yapıştırmak istiyorum.

Kopyalama için kodları ekledim ancak yapıştırma konusunda sorun yaşıyorum.

Gönderilecek mailin taslağının aşağıdaki gibi olmasını istiyorum.

Desteğinizi rica ederim.

Merhaba,

Kopyaladığım tablo (otomatik gelecek)

Bilgilerinize
iyi çalışmalar

Kod: 
Private Sub CommandButton1_Click()

Dim Outapp As Object
Dim Outmail As Object

Set Outapp = CreateObject("Outlook.Application")
Set Outmail = Outapp.CreateItem(0)

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

Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).Copy

With Outmail
.To = "ayteking@hotmail.com"
.CC = "ayteking@hotmail.com;ayteking@hotmail.com"
.BCC = ""
.Subject = "Deneme"
.Body = "Merhaba ," & Chr(13) & _
"" & Chr(13) & _
"Bilginize" & Chr(13) & _
"iyi çalışmalar"
.Send

End With

Set Outmall = Nothing
Set Outapp = Nothing

End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aşağıdaki kodu deneyin.

Kaynak; http://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Kod: 
Sub Mail_Selection_Range_Outlook_Body()
'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2013
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").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

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

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

    On Error Resume Next
    With OutMail
[COLOR="Red"]        .Display
[/COLOR]        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Teşekkür ederim istediğimden iyi oldu.

Son iki soru ; Outlook ta bulunan imzayı eklemesi icin bu makroya birşeyler yapabilir miyiz ?

ve Mail konusu alanına, eklenen tabloda yer alan bir yazıyı yazdırabilir miyiz?
 
Son düzenleme:
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Merhaba,

İmza için üsteki mesajımda ki koda kırmızı renkli eklemeyi yapmanız sorunu çözecektir.

Mail konusu içinse aşağıdaki bölümü;

Kod: 
.Subject = "This is the Subject line"
Bunun gibi yazabilirsiniz;

Kod: 
.Subject = Range("A1").Value
Bu şekilde A1 hücresindeki veriyi konu kısmına yazdırmış olursunuz.
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Korhan Ayhan' Alıntı:
Merhaba,

İmza için üsteki mesajımda ki koda kırmızı renkli eklemeyi yapmanız sorunu çözecektir.

Mail konusu içinse aşağıdaki bölümü;

Kod: 
.Subject = "This is the Subject line"
Bunun gibi yazabilirsiniz;

Kod: 
.Subject = Range("A1").Value
Bu şekilde A1 hücresindeki veriyi konu kısmına yazdırmış olursunuz.
Genişletmek için tıkla ...
Desteğiniz için çok teşekkür ederim Subject oldu ancak HTML imza eklenmedi

Kodu biraz daha geliştirdim ve oto veri çekip oto gönderiyor. Sadece satır sayısını girmem yetiyor.

İmza ve mail body si için desteğinizi rica ederim.

Merhaba,

"Buraya tablo gelecek"

Bilgilerinize
iyi Çalışmalar

Tüm Kodlar

Kod: 
Sub mail_hazirlama()
satir = InputBox("Mail Gönderilecek Satırı Giriniz, Litfeen :)")

Sheets("e_mail").Select
Columns("B:C").Select
Selection.Delete
    
    Sheets("tum_data").Select
    Range("A1:V1").Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("tum_data").Select
    Range(Cells(satir, 1), Cells(satir, 22)).Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Rows("17").Select
    Selection.Delete Shift:=xlUp
    Rows("18:20").Select
    Selection.Delete Shift:=xlUp
    Range("C3:C4").Select
    Selection.NumberFormat = "d/m/yyyy"
    Columns("B:B").ColumnWidth = 20
    Columns("B:B").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Columns("C:C").ColumnWidth = 94
    Columns("C:C").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Range("C13").Select
        With Selection
        .WrapText = True
    End With
        Rows("13:13").RowHeight = 124.5
    
    'Sheets("E_Mail").Select
    'Sheets("E_Mail").Copy
    Range("B2:C17").Select
    Selection.Copy
    
    'Application.Dialogs(xlDialogSendMail).Show

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("E_Mail").Range("B1:D").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Mail Göndermek İstediğiniz Excel Tabloyu Şeçiniz" & _
               vbNewLine & "Doğu Alanı Şeçtiğine Emin misin? :)", vbOKOnly
        Exit Sub
    End If

    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 = "Mail adresi"
        .CC = "Mail adresi;Mail adresi;Mail adresi"
        .BCC = ""
        .Subject = Range("C11").Value
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Şimdi bir deneme yaptım.

Outlookta imza oluşturdum. Daha sonra kod içindeki HTMLBODY satırını aşağıdaki gibi değiştirdim.

Böylece hem tanımlı imzam mail penceresinde çıktı. Hem de tablo eklenmiş oldu.


Kod: 
        .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Korhan Ayhan' Alıntı:
Şimdi bir deneme yaptım.

Outlookta imza oluşturdum. Daha sonra kod içindeki HTMLBODY satırını aşağıdaki gibi değiştirdim.

Böylece hem tanımlı imzam mail penceresinde çıktı. Hem de tablo eklenmiş oldu.


Kod: 
        .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
Genişletmek için tıkla ...
Merhaba,

Desteğiniz için ne kadar teşekkür etsem azdır.

Şu an herşey tam istediğim gibi çalışmaktadır.

Kullanmak isteyenler için kodların düzenlenmiş hali aşağıdadır;

Kod: 
Sub mail_hazirlama()
satir = InputBox("Mail Gönderilecek Satırı Giriniz, Litfeen :)")

Sheets("e_mail").Select
Columns("B:C").Select
Selection.Delete
    
    Sheets("tum_data").Select
    Range("A1:V1").Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("tum_data").Select
    Range(Cells(satir, 1), Cells(satir, 22)).Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Rows("17").Select
    Selection.Delete Shift:=xlUp
    Rows("18:20").Select
    Selection.Delete Shift:=xlUp
    Range("C3:C4").Select
    Selection.NumberFormat = "d/m/yyyy"
    Columns("B:B").ColumnWidth = 20
    Columns("B:B").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Columns("C:C").ColumnWidth = 94
    Columns("C:C").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Range("C13").Select
        With Selection
        .WrapText = True
    End With
        Rows("13:13").RowHeight = 124.5
    
    'Sheets("E_Mail").Select
    'Sheets("E_Mail").Copy
    Range("B2:C17").Select
    Selection.Copy
    
    'Application.Dialogs(xlDialogSendMail).Show

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("E_Mail").Range("B1:D").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Mail Göndermek İstediğiniz Excel Tabloyu Şeçiniz" & _
               vbNewLine & "Doğu Alanı Şeçtiğine Emin misin? :)", vbOKOnly
        Exit Sub
    End If

    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 = "Mail adresi"
        .CC = "Mail adresi;Mail adresi;Mail adresi"
        .BCC = "Mail adresi"
        .Subject = Range("C11").Value
                .Display
                .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)

    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Bol bol SELECT komutu kullanmışsınız.

Bunlar daha da kısaltılabilir...
 
U

ugomor

Katılım
11 Eylül 2008
Mesajlar
12
Excel Vers. ve Dili
Office 2003
aytekin44' Alıntı:
Merhabalar,

Aşağıdaki kodlarda otomatik mail gönderebiliyorum ancak excelde şeçili alanı kopyalayıp mail sayfasına yapıştırmak istiyorum.

Kopyalama için kodları ekledim ancak yapıştırma konusunda sorun yaşıyorum.

Gönderilecek mailin taslağının aşağıdaki gibi olmasını istiyorum.

Desteğinizi rica ederim.

Merhaba,

Kopyaladığım tablo (otomatik gelecek)

Bilgilerinize
iyi çalışmalar

Kod: 
Private Sub CommandButton1_Click()

Dim Outapp As Object
Dim Outmail As Object

Set Outapp = CreateObject("Outlook.Application")
Set Outmail = Outapp.CreateItem(0)

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

Range("B2:D" & Cells.SpecialCells(xlCellTypeLastCell).Row).Copy

With Outmail
.To = "ayteking@hotmail.com"
.CC = "ayteking@hotmail.com;ayteking@hotmail.com"
.BCC = ""
.Subject = "Deneme"
.Body = "Merhaba ," & Chr(13) & _
"" & Chr(13) & _
"Bilginize" & Chr(13) & _
"iyi çalışmalar"
.Send

End With

Set Outmall = Nothing
Set Outapp = Nothing

End Sub
Genişletmek için tıkla ...
Merhaba,

Yeni konu açmak istemedim. Bu konuya ek olarak bir şey sormak istiyorum. aşağıdaki kod ile mail gönderimi yapabiliyorum. Fakat mail adresini kodun içine yazmam gerekiyor. mail adresini örneğim H5 hücresinden alarak gönderim yapabiliyormuyuz? Ek olarak aynı makroya devam ederek 2. maili atabilmemiz mümkün mü? (Yani makroyu alta kopyalayarak başka bir veriyi başka mail adresine göndermek için)

Saygılar

Kod: 
Sub Erkan_Mob()
   
   ' Select the range of cells on the active worksheet.
   Sheets("Sistem").Select
   Range("A1:D2").Select
   
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
      .Introduction = "Online Satış Kargo Takip Bilgileriniz"
      .Item.To = "ugomortr@yahoo.com"
      .Item.CC = "ugomortr@yahoo.com"
      .Item.Subject = "Online Satış Kargo Takip Bilgileriniz"
      .Item.Send
   End With
   Sheets("Sistem").Select
   Range("H1").Select
 End Sub
 
Son düzenleme:
U

ugomor

Katılım
11 Eylül 2008
Mesajlar
12
Excel Vers. ve Dili
Office 2003
From kısmında hata veriyor. İkinci mail adresinden gönderim nasıl yapabilirim?


Kod: 
Sub Erkan_Mob()
   
   ' Select the range of cells on the active worksheet.
   Sheets("Mail1").Select
   Range("A1:G20").Select
   
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   ' Set the optional introduction field thats adds
   ' some header text to the email body. It also sets
   ' the To and Subject lines. Finally the message
   ' is sent.
   With ActiveSheet.MailEnvelope
      .Item.From = "ugomortr@yahoo.com"
      .Item.To = Range("R1").Value
      .Item.CC = "ugomortr@yahoo.com"
      .Item.BCC = "ugomortr@yahoo.com"
      .Item.Subject = "Online Satış Kargo Bilgileriniz"
      .Item.Send
   End With
 End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Aynı maili çoklu mail adresine göndermek için aşağıdaki kodu deneyebilirsiniz. Göndermek istediğiniz mail adresleri R1:R5 aralığında olsun. Dilerseniz satır sayısını arttırabilirsiniz.

Kod: 
Option Explicit

Sub Mail_Gonder()
    Dim Alan As Range, Veri As Range, Adres As String

    On Error GoTo Son

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

    Set Alan = Range("A1:G20")

    For Each Veri In Range("R1:R5")
        If Veri.Value <> "" Then
            If Adres = "" Then
                Adres = Veri.Value
            Else
                Adres = Adres & ";" & Veri.Value
            End If
        End If
    Next

    With Alan
        ActiveWorkbook.EnvelopeVisible = True
        With .Parent.MailEnvelope
            .Introduction = ""
            With .Item
                .To = Adres
                .CC = "ugomortr@yahoo.com"
                .BCC = "ugomortr@yahoo.com"
                .Subject = "Online Satış Kargo Bilgileriniz"
                .Send
            End With
        End With
    End With

Son:
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    ActiveWorkbook.EnvelopeVisible = False
End Sub
 
U

ugomor

Katılım
11 Eylül 2008
Mesajlar
12
Excel Vers. ve Dili
Office 2003
Üstad Teşekkürler,
Bende aşağıdaki kodları uyguladım. 20 kişiye kadar mail gidiyor fakat. 5 kişilik mail gönderdiğimde boş olan 6. kayıttayken hata veriyor. Boşsa atla gibi bir değer varmıdır? Daha araştırmaya başlamadım. Alakanız ve yardımlarınız için teşekkür ederim.

Kod: 
Sub Erkan_Mob()
   
   ' Select the range of cells on the active worksheet.
   Sheets("Mail1").Select
   Range("A1:G20").Select
   
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   With ActiveSheet.MailEnvelope
      .Item.SentOnBehalfOfName = "ugomortr@yahoo.com"
      .Item.To = Range("R1").Value
      .Item.CC = ""
      .Item.BCC = "ugomortr@yahoo.com"
      .Item.Subject = "Online Satış Kargo Bilgileriniz"
      .Item.Send
   End With
   ' Select the range of cells on the active worksheet.
   Sheets("Mail2").Select
   Range("A1:G20").Select
   
   ' Show the envelope on the ActiveWorkbook.
   ActiveWorkbook.EnvelopeVisible = True
   
   With ActiveSheet.MailEnvelope
      .Item.SentOnBehalfOfName = "ugomortr@yahoo.com"
      .Item.To = Range("R1").Value
      .Item.CC = ""
      .Item.BCC = "ugomortr@yahoo.com"
      .Item.Subject = "Online Satış Kargo Bilgileriniz"
      .Item.Send
   End With
End Sub
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosyanızın yapısını bilmediğim için verdiğiniz kod örneğinden yola çıkarak cevap vermeye çalışıyorum. Anladığım kadarıyla birden fazla sayfanız var ve her sayfayı farklı kişilere mail atmak istiyorsunuz.

Boş olan kayıttan kastınız nedir? Sayfa mı boş, yoksa mail adresi mi boş?

Örnek dosya eklerseniz daha sağlıklı sonuçlar elde edebiliriz. (Paylaşım sitelerine yükleyip link verebilirsiniz.)

Not: Foruma kod eklerken kod tagını kullanmanız gerekiyor. Yoksa yazdığınız mesaj içinde kodlar kayboluyor. Ben mesajlarınızı düzenledim. Kod tagı mesajı yazdığınız penceredeki # işareti ile eklenmektedir.
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Korhan Ayhan' Alıntı:
Bol bol SELECT komutu kullanmışsınız.

Bunlar daha da kısaltılabilir...
Genişletmek için tıkla ...
Hocam merhaba,

Daha önce ki desteğinizi için tekrar teşekkür ederim.Inputbox ile satır sayısını girerek oto mail gönderebiliyorum ancak örneğin 2. satır ile 10. satır aralığını girdiğimde otomatik olarak hepsini ayrı ayrı atmasını nasıl sağlayabilirim?

Çift Inputbox ile yapıyorduk ama sanırım bir yanlış yapıyorum. Desteğinizi rica ederim.

Kod: 
Sub mail_hazirlama()
[COLOR="Red"]satir = InputBox("Mail Gönderilecek Satırı Giriniz")
[/COLOR]
Sheets("e_mail").Select
Columns("B:C").Select
Selection.Delete
    
    Sheets("tum_data").Select
    Range("A1:V1").Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("tum_data").Select
    Range(Cells(satir, 1), Cells(satir, 22)).Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Rows("17").Select
    Selection.Delete Shift:=xlUp
    Rows("18:20").Select
    Selection.Delete Shift:=xlUp
    Range("C3:C4").Select
    Selection.NumberFormat = "d/m/yyyy"
    Columns("B:B").ColumnWidth = 20
    Columns("B:B").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Columns("C:C").ColumnWidth = 94
    Columns("C:C").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Range("C13").Select
        With Selection
        .WrapText = True
    End With
        Rows("13:13").RowHeight = 124.5
    
    'Sheets("E_Mail").Select
    'Sheets("E_Mail").Copy
    Range("B2:C17").Select
    Selection.Copy
    
    'Application.Dialogs(xlDialogSendMail).Show

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("E_Mail").Range("B1:D").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Mail Göndermek İstediğiniz Excel Tabloyu Şeçiniz" & _
               vbNewLine & "Doğu Alanı Şeçtiğine Emin misin? :)", vbOKOnly
        Exit Sub
    End If

    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 = "Mail adresi"
        .CC = "Mail adresi;Mail adresi;Mail adresi"
        .BCC = "Mail adresi"
        .Subject = Range("C11").Value
                .Display
                .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)

    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
İki inputbox oluşturun.

Satir1 ve Satir2 adında olabilir.

Daha sonra bu değerleri döngüye alırsanız satır satır mail atabilirsiniz.
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Korhan Ayhan' Alıntı:
İki inputbox oluşturun.

Satir1 ve Satir2 adında olabilir.

Daha sonra bu değerleri döngüye alırsanız satır satır mail atabilirsiniz.
Genişletmek için tıkla ...
Nerde hata yapıyorum bulamadım. Kırmızı alanları ekledim box lar açılıyor giriyorum ancak mavi yazdığım alan hata veriyor.

Desteğinizi rica ederim.

Kod: 
Sub mail_hazirlama()

[COLOR="Red"]satir1 = InputBox("Mail Gönderilecek 1. Satırı Giriniz")
satir2 = InputBox("Mail Gönderilecek 2. Satırı Giriniz")

For i = 1 To 2 Step 1
Next i[/COLOR]

Sheets("e_mail").Select
Columns("B:C").Select
Selection.Delete
    
    Sheets("tum_data").Select
    Range("A1:V1").Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("tum_data").Select
    [COLOR="Blue"]Range(Cells(satir, 1), Cells(satir, 22)).Select[/COLOR]
    Selection.Copy
    Sheets("e_mail").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Rows("17").Select
    Selection.Delete Shift:=xlUp
    Rows("18:20").Select
    Selection.Delete Shift:=xlUp
    Range("C3:C4").Select
    Selection.NumberFormat = "d/m/yyyy"
    Columns("B:B").ColumnWidth = 20
    Columns("B:B").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Columns("C:C").ColumnWidth = 94
    Columns("C:C").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Range("C13").Select
        With Selection
        .WrapText = True
    End With
        Rows("13:13").RowHeight = 124.5
    
    'Sheets("E_Mail").Select
    'Sheets("E_Mail").Copy
    Range("B2:C17").Select
    Selection.Copy
    
    'Application.Dialogs(xlDialogSendMail).Show

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("E_Mail").Range("B1:D").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Mail Göndermek İstediğiniz Excel Tabloyu Şeçiniz" & _
               vbNewLine & "Doğu Alanı Şeçtiğine Emin misin? :)", vbOKOnly
        Exit Sub
    End If

    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 = "Mail adresi"
        .CC = "Mail adresi;Mail adresi;Mail adresi"
        .BCC = "Mail adresi"
        .Subject = Range("C11").Value
                .Display
                .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)

    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Girilecek iki satır aralığını döngü olarak nasıl yaparım arkadaşlar,

Destek bekliyorum


aytekin44' Alıntı:
Nerde hata yapıyorum bulamadım. Kırmızı alanları ekledim box lar açılıyor giriyorum ancak mavi yazdığım alan hata veriyor.

Desteğinizi rica ederim.

Kod: 
Sub mail_hazirlama()

[COLOR="Red"]satir1 = InputBox("Mail Gönderilecek 1. Satırı Giriniz")
satir2 = InputBox("Mail Gönderilecek 2. Satırı Giriniz")

For i = 1 To 2 Step 1
Next i[/COLOR]

Sheets("e_mail").Select
Columns("B:C").Select
Selection.Delete
    
    Sheets("tum_data").Select
    Range("A1:V1").Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("tum_data").Select
    [COLOR="Blue"]Range(Cells(satir, 1), Cells(satir, 22)).Select[/COLOR]
    Selection.Copy
    Sheets("e_mail").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Rows("17").Select
    Selection.Delete Shift:=xlUp
    Rows("18:20").Select
    Selection.Delete Shift:=xlUp
    Range("C3:C4").Select
    Selection.NumberFormat = "d/m/yyyy"
    Columns("B:B").ColumnWidth = 20
    Columns("B:B").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Columns("C:C").ColumnWidth = 94
    Columns("C:C").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Range("C13").Select
        With Selection
        .WrapText = True
    End With
        Rows("13:13").RowHeight = 124.5
    
    'Sheets("E_Mail").Select
    'Sheets("E_Mail").Copy
    Range("B2:C17").Select
    Selection.Copy
    
    'Application.Dialogs(xlDialogSendMail).Show

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("E_Mail").Range("B1:D").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Mail Göndermek İstediğiniz Excel Tabloyu Şeçiniz" & _
               vbNewLine & "Doğu Alanı Şeçtiğine Emin misin? :)", vbOKOnly
        Exit Sub
    End If

    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 = "Mail adresi"
        .CC = "Mail adresi;Mail adresi;Mail adresi"
        .BCC = "Mail adresi"
        .Subject = Range("C11").Value
                .Display
                .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)

    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Genişletmek için tıkla ...
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,333
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Dosyanızı neden eklemiyorsunuz?

Bu şekilde ne yapmak istediğiniz anlaşılmıyor.
 
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
Korhan Ayhan' Alıntı:
Dosyanızı neden eklemiyorsunuz?

Bu şekilde ne yapmak istediğiniz anlaşılmıyor.
Genişletmek için tıkla ...
Hocam merhaba,

örnek dosya ektedir.

Desteğinizi rica ederim.

Düzeltme:

Aşağıdaki şekilde düzeltip çalıştırdım.

basla = InputBox("Mail Gönderilecek Satırı Giriniz")
bitir = InputBox("Mail Gönderilecek Satırı Giriniz")

For satir = basla To bitir Step 1

Next satir
 
Son düzenleme:
aytekin44

aytekin44

Altın Üye
Katılım
12 Nisan 2014
Mesajlar
72
Excel Vers. ve Dili
Microsoft 365 Enterprise En 64 Bit
Altın Üyelik Bitiş Tarihi
20-10-2025
aytekin44' Alıntı:
Merhaba,

Desteğiniz için ne kadar teşekkür etsem azdır.

Şu an herşey tam istediğim gibi çalışmaktadır.

Kullanmak isteyenler için kodların düzenlenmiş hali aşağıdadır;

Kod: 
Sub mail_hazirlama()
satir = InputBox("Mail Gönderilecek Satırı Giriniz, Litfeen :)")

Sheets("e_mail").Select
Columns("B:C").Select
Selection.Delete
    
    Sheets("tum_data").Select
    Range("A1:V1").Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("B2").Select
    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=True
    Sheets("tum_data").Select
    Range(Cells(satir, 1), Cells(satir, 22)).Select
    Selection.Copy
    Sheets("e_mail").Select
    Range("C2").Select
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
    Application.CutCopyMode = False
    
    Rows("2:3").Select
    Selection.Delete Shift:=xlUp
    Rows("17").Select
    Selection.Delete Shift:=xlUp
    Rows("18:20").Select
    Selection.Delete Shift:=xlUp
    Range("C3:C4").Select
    Selection.NumberFormat = "d/m/yyyy"
    Columns("B:B").ColumnWidth = 20
    Columns("B:B").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Columns("C:C").ColumnWidth = 94
    Columns("C:C").Select
        With Selection
        .HorizontalAlignment = xlLeft
        End With
    Range("C13").Select
        With Selection
        .WrapText = True
    End With
        Rows("13:13").RowHeight = 124.5
    
    'Sheets("E_Mail").Select
    'Sheets("E_Mail").Copy
    Range("B2:C17").Select
    Selection.Copy
    
    'Application.Dialogs(xlDialogSendMail).Show

    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a fixed range if you want
    Set rng = Sheets("E_Mail").Range("B1:D").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "Mail Göndermek İstediğiniz Excel Tabloyu Şeçiniz" & _
               vbNewLine & "Doğu Alanı Şeçtiğine Emin misin? :)", vbOKOnly
        Exit Sub
    End If

    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 = "Mail adresi"
        .CC = "Mail adresi;Mail adresi;Mail adresi"
        .BCC = "Mail adresi"
        .Subject = Range("C11").Value
                .Display
                .HTMLBody = "Merhaba," & "<br>" & _
                    RangetoHTML(rng) & "<br><br>" & _
                    "Bilgilerinize." & "<br><br>" & _
                    "İyi Çalışmalar." & "<br><br>" & _
                    .HTMLBody
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub


Function RangetoHTML(rng As Range)

    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"

    'Copy the range and create a new workbook to past the data in
    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

    'Publish the sheet to a htm file
    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

    'Read all data from the htm file into RangetoHTML
    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=")

    'Close TempWB
    TempWB.Close savechanges:=False

    'Delete the htm file we used in this function
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
Genişletmek için tıkla ...
*************
Merhabalar ,

Alıntıda yer alan kodlar ile otomatik mail gönderimi yapıyorum ancak art arda çok fazla mail gönderdiğim için takibi alıcılar tarafından zor olmaktadır.

Satır aralığı girerek döndü ile gönderim yapıyorum ancak bu gönderimleri 5 dakika ara ile döngüyü bozmadan Nasıl yapabilirim ?

Desteğinizi rica ederim

İyi çalışmalar dilerim
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst