Belirli kriterlere göre süzüp html formatında mail gönderme.

denizfatihi · Çarşamba saat 23:10'de

Merhaba,

Kod normalde süzme işlemini ilgili alanları seçiyor yalnız kopyala yapıştır kısmına gelince boş alan yapıştırdığı için mail de boş geliyor.
Hangi kısmında hata yapıyorum ? Teşekkür ederim.

Kod:

Sub MailBilgi()

Zaman = Time
Tarih = Date + 21

Dim EmailApp As Outlook.Application
Dim Source As String
Dim myRange As Range
Set myRange = Selection
Set EmailApp = New Outlook.Application
Dim EmailItem As Outlook.MailItem
Dim sh As Worksheet
Set EmailItem = EmailApp.CreateItem(olMailItem)

 On Error Resume Next
 Sayfa1.Select
  'Kredi.Select
    
Set sh = Sheets("Kredi")
        
   ActiveSheet.Range("$A$2:$D$5000").AutoFilter Field:=2, Criteria1:="<=" & CLng(CDate(Tarih)), Operator:=xlAnd
        
 
Sayfa1.Range("A2").Select
Range(Selection, Selection.End(xlDown)).Select
Range(Selection, Selection.End(xlToRight)).Select

EmailItem.To = "test@test.com.tr"
EmailItem.Subject = "Vadesi gelen/yaklaşan kredi/krediler"
EmailItem.HTMLBody = rangetoHTML(myRange)
'EmailItem.Send
EmailItem.Send
On Error GoTo 0
ActiveSheet.Range("$A$2:$D$5000").AutoFilter 'Field:=2
'ActiveSheet.ListObjects("Sorgu1").Range.AutoFilter Field:=20
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

tugkan · Dün 08:34 da

Sorununuzun kopyalama ve yapıştırma işlemleri sırasında kaynak verilerin doğru alınmaması ve bu yüzden e-postada boş alanların gönderilmesi olduğunu anlıyorum. Bu durum genellikle, seçili hücre aralığında boş hücrelerin olması ya da kullanılan yöntemle doğru hücrelerin kopyalanamamasından kaynaklanabilir.

Kodu detaylıca incelediğimde, şunu fark ettim: myRange = Selection ifadesi aslında doğrudan seçili hücreleri alıyor ama bu aralık boş olabilir ya da veriler doğru şekilde seçilemiyor olabilir.

Adımlarla çözüm önerisi:

1. Doğru Hücre Aralığını Belirleme:
Veriyi seçerken CurrentRegion veya SpecialCells(xlCellTypeVisible) gibi yöntemlerle sadece filtrelenmiş, görünür hücreleri alabilirsiniz. Böylece gizlenmiş hücreler dahil edilmez ve boş hücreler gönderilmez.

2. Sadece Görünen Hücreleri Kopyalama:
Filtre sonrası sadece görünür hücrelerin HTML formatında alınması için SpecialCells ile sadece görünür hücreleri seçmek faydalı olur.

Aşağıdaki şekilde myRange ayarını düzenledim, böylece sadece filtrelenen verileri alıp e-posta gönderirsiniz:

Kod:

Sub MailBilgi()

    Dim Zaman As String
    Dim Tarih As Date
    Dim EmailApp As Object
    Dim myRange As Range
    Dim EmailItem As Object
    Dim sh As Worksheet

    Zaman = Time
    Tarih = Date + 21

    ' Outlook uygulamasını başlat
    Set EmailApp = CreateObject("Outlook.Application")
    Set EmailItem = EmailApp.CreateItem(0) ' olMailItem = 0

    ' Kredi sayfasına git ve filtre uygula
    On Error Resume Next
    Set sh = Sheets("Kredi")
    sh.Select
    sh.Range("$A$2:$D$5000").AutoFilter Field:=2, Criteria1:="<=" & CLng(CDate(Tarih)), Operator:=xlAnd

    ' Yalnızca filtrelenmiş, görünür hücreleri seç
    Set myRange = sh.Range("A2:D5000").SpecialCells(xlCellTypeVisible)

    ' E-posta oluşturma
    With EmailItem
        .To = "test@test.com.tr"
        .Subject = "Vadesi gelen/yaklaşan kredi/krediler"
        .HTMLBody = rangetoHTML(myRange)
        .Send ' Gönderim
    End With

    ' Filtreyi temizle
    sh.AutoFilterMode = False

    On Error GoTo 0

End Sub

Function rangetoHTML(rng As Range) As String
    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"

    ' Veriyi geçici olarak yeni bir kitapta kopyalayın
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        Application.CutCopyMode = False
    End With

    ' HTML dosyasını yayınlayın
    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

    ' HTML dosyasını oku
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    rangetoHTML = ts.readall
    ts.Close

    ' Geçici dosyayı sil
    TempWB.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

3. Açıklamalar:

SpecialCells(xlCellTypeVisible): Bu ifade, sadece filtrelenmiş olan ve görünür hücreleri seçer. Boş satırları ya da gizlenen satırları göz ardı eder.
myRange doğru şekilde ayarlandığı için sadece görünür ve dolu hücreler e-posta içinde yer alır.

Bu düzenlemeyle, filtre uygulandıktan sonra sadece vadesi yaklaşan krediler e-postaya dahil edilecektir.

pitchoute · Dün 11:28 da

Merhaba, deneyip sonucu paylaşabilir misiniz;

Kod:

Sub MailBilgi()

    Zaman = Time
    Tarih = Date + 21
    
    Dim EmailApp As Outlook.Application
    Dim myRange As Range
    Set EmailApp = New Outlook.Application
    Dim EmailItem As Outlook.MailItem
    Dim sh As Worksheet
    Set EmailItem = EmailApp.CreateItem(olMailItem)
    
    On Error Resume Next
    Set sh = Sheets("Kredi")
    sh.Select
            
    sh.Range("$A$2:$D$5000").AutoFilter Field:=2, Criteria1:="<=" & CLng(CDate(Tarih)), Operator:=xlAnd
    
    Set myRange = sh.Range("$A$2:$D$5000").SpecialCells(xlCellTypeVisible)
    
    EmailItem.To = "test@test.com.tr"
    EmailItem.Subject = "Vadesi gelen/yaklaşan kredi/krediler"
    EmailItem.HTMLBody = rangetoHTML(myRange)
    'EmailItem.Send
    EmailItem.Send
    On Error GoTo 0
    sh.Range("$A$2:$D$5000").AutoFilter
End Sub

denizfatihi · Dün 12:18 da

Merhaba,

sayın tugkan detaylı anlatım için çok teşekkür ederim, çalıştı yalnız benzer bir bilgilendirme sayfamızda database'ten çekilen veriler için sorgu var alt kısmda belirttim buradaki sorun ikinci alandaki kopyalacak alanı seçerken başlıkları almaması sadece satırları kopyalaması, bunu da direkt hücre aralığını verip sorunu aştık, ama yapıltır esnasında kolonları dar yapıştırdığı için gelen mail içinde alanlar "#####" şeklinde geliyor,

.Cells(1).EntireColumns.AutoFit şeklinde satır ekledim ama işe yaramadı.

sayın pitchoute size de ayrıca teşekkür ederim.

Kod:

sh.Range("Sorgu1").AutoFilter Field:=2, Criteria1:="<=" & CLng(CDate(Tarih)), Operator:=xlAnd

Kod:

Set myRange = sh.Range("Sorgu1").SpecialCells(xlCellTypeVisible)

tugkan · Dün 12:49 da

E-postada "#####" şeklinde görünen alanlar, genellikle hücrelerin içerdiği verilerin hücre genişliğini aştığı anlamına gelir. Bu durumu çözmek için hücrelerin genişliğini dinamik olarak ayarlamak yeterli olmayabilir, çünkü e-posta gönderildiğinde formatlama doğru bir şekilde uygulanmayabilir.

Önerilen Çözüm: Kopyalanan hücrelerin genişliğini artırmak için aşağıdaki adımları uygulayabiliriz:

HTML İçeriği Ayarlama: HTML içeriği oluştururken, içeriğin genişliği ile ilgili CSS stilleri ekleyebiliriz.
Özel Kopyalama Yöntemi: Kopyalanan aralığın otomatik genişliğini ayarlamak yerine, HTML oluşturma aşamasında direkt genişlik ayarlarını yaparak görünümünü düzeltebiliriz.

Aşağıdaki kodda, HTML oluşturma işlevine hücre genişliğini dinamik olarak ayarlayan bir CSS stili ekliyorum:

Kod:

Function rangetoHTML(rng As Range) As String
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim cell As Range
    Dim rowHtml As String
    Dim html As String

    TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

    ' HTML başlıkları ve stil tanımları
    html = "<html><body><table style='border-collapse:collapse;'>"
    
    ' Satırları HTML formatında oluştur
    For Each cell In rng.Rows
        rowHtml = "<tr>"
        For Each c In cell.Cells
            rowHtml = rowHtml & "<td style='border:1px solid black; padding:5px;'>" & c.Value & "</td>"
        Next c
        rowHtml = rowHtml & "</tr>"
        html = html & rowHtml
    Next cell

    html = html & "</table></body></html>"

    ' HTML içeriğini döndür
    rangetoHTML = html
End Function

Açıklama:

CSS Stilleri: style='border-collapse:collapse;' ekleyerek hücrelerin kenar boşluklarını ortadan kaldırdım ve daha düzgün bir görünüm elde ettim.
Hücre Genişliği: Bu çözüm, hücrelerin genişliğini dinamik olarak ayarlamak yerine, doğrudan e-posta içeriği olarak gelen verilerin her bir hücresine stiller ekleyerek görünümü iyileştirir.

Ek Özelleştirmeler:

Eğer belirli bir genişlik ayarı yapmak istiyorsanız, width stilini her hücre için ayarlayabilirsiniz. Örneğin: style='border:1px solid black; padding:5px; width:100px;'.

Bu yöntemle, e-postada görünen içerik daha düzenli olacak ve "#####" görüntüsünden kaçınmış olacaksınız.
Denedikten sonra sonucu paylaşır mısınız

denizfatihi · Dün 13:54 da

sayın tugkan işlem çalışmaya başladığı zaman süreç çok uzun sürüyor (4 satır için ortalam 5 dakika gibi) ve gelen mail anlamsız şeklinde geliyor.

tugkan · Dün 14:18 da

İşlemlerden önce yedek almayı unutmayınız.

Sürecin yavaş ilerlemesi ve e-posta içeriğinin doğru görünmemesi, kopyalama ve HTML formatına dönüştürme aşamasında büyük verilerin veya fazla işlemin gereksiz yere yapılmasından kaynaklanıyor olabilir.

Daha verimli bir çözüm için, işlemi optimize edebiliriz. Bunun için şu önerileri dikkate alalım:

1. Optimize Edilmiş HTML Formatı:

Hücrelerden verileri alırken doğrudan HTML oluşturmak yerine, sadece değerleri basitçe alıp daha verimli bir şekilde formatlayabiliriz.

2. Gereksiz İşlemleri Azaltma:

Veriyi geçici bir çalışma kitabına yapıştırmak yerine, doğrudan mevcut aralıktan HTML formatına dönüştürebiliriz.

Aşağıdaki optimize edilmiş kodu deneyebilirsiniz. Bu sürüm, işlemi hızlandıracak ve daha anlamlı bir e-posta içeriği sağlayacaktır:

Optimize Edilmiş VBA Kodu:

Kod:

Function rangetoHTML(rng As Range) As String
    Dim html As String
    Dim cell As Range
    Dim rowHtml As String

    ' HTML başlıkları ve stil tanımları
    html = "<html><body><table style='border-collapse:collapse; border:1px solid black;'>"
    
    ' Satırları HTML formatında oluştur
    For Each cell In rng.Rows
        rowHtml = "<tr>"
        For Each c In cell.Cells
            rowHtml = rowHtml & "<td style='border:1px solid black; padding:5px;'>" & c.Value & "</td>"
        Next c
        rowHtml = rowHtml & "</tr>"
        html = html & rowHtml
    Next cell

    ' HTML sonlandır
    html = html & "</table></body></html>"

    ' HTML içeriğini döndür
    rangetoHTML = html
End Function

Bu Yöntemin Faydaları:

Daha Hızlı İşlem: Geçici bir çalışma kitabı oluşturmadan doğrudan HTML formatında tablo oluşturuyoruz. Bu, işlemi hızlandıracaktır.
Anlamlı İçerik: Veriler doğrudan HTML tablo yapısında düzenli olarak gönderilecektir.
Boşluk Problemi: padding ve border stilleri ile hücreler daha düzenli görünecek.

denizfatihi · Dün 15:24 da

merhaba, gelen maillerin alıması uzun zaman alıyor, açılınca dikkatimi çeken çok sayıda boş satır olması büyük ihtimalle döngüyü bitirmek için bir şeyi atladık gibi geliyor.

Biolightant · Dün 17:55 da

Merhaba,
Alternatif kodlar.

C++:

Option Explicit
'Biolight 2024 - Eppur Si Muove

Sub HucreHTMLToOutlook()
    Application.ScreenUpdating = False

    Dim veriAraligi As Range
    Dim sonSatir As Long
    Dim yeniSayfa As Worksheet
    Dim dosyaYolu As String
    dosyaYolu = Environ("TEMP") & "\Rapor.htm"

    Dim objOutlook As Object
    Dim objMail As Object
    Dim strHTMLBody As String
    Dim fso As Object
    Dim htmlFile As Object
    Dim htmlContent As String

    ' B sütününda Son dolu satırı bul
    sonSatir = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
    
    ActiveSheet.AutoFilterMode = False
    ' Filtreleme işlemi A1:DsonSatir
    ActiveSheet.Range("$A$1:$D$" & sonSatir).AutoFilter Field:=2, Criteria1:="<=" & CLng(CDate(Date))

    ' Sadece filtrelenmiş görünür hücreleri seç
    On Error Resume Next
    Set veriAraligi = ActiveSheet.Range("$A$2:$D$" & sonSatir).SpecialCells(xlCellTypeVisible)
        If veriAraligi.Address = "$A$1:$D$1" Then
            MsgBox "Vadesi gelen/yaklaşan kredi/krediler YOK!", vbInformation, Date & " tarihli vade YOK"
            ActiveSheet.AutoFilterMode = False
            Application.ScreenUpdating = True
            Exit Sub
        End If
    On Error GoTo 0
    
    ' Geçici sayfa oluştur
    Set yeniSayfa = ThisWorkbook.Worksheets.Add
    yeniSayfa.Name = "Gecici_Veri"
    
    ' Filtrelenmiş verileri yeni sayfaya kopyala
    veriAraligi.Copy Destination:=yeniSayfa.Range("A1")
    yeniSayfa.Columns.AutoFit

    ' Dosya var mı kontrolü
    If Dir(dosyaYolu) <> "" Then
        Kill dosyaYolu ' Eğer dosya varsa, önce sil
    End If

    ' Verileri HTML olarak yayınla
    With ActiveWorkbook.PublishObjects.Add(xlSourceRange, _
        dosyaYolu, _
        "Gecici_Veri", yeniSayfa.Range("A1").CurrentRegion.Address, xlHtmlStatic, _
        "Rapor_" & Format(Now, "YYYYMMDD_HHMMSS"), "")
        .Publish (True)
        .AutoRepublish = False
    End With

    ' Geçici sayfayı sil
    Application.DisplayAlerts = False
        yeniSayfa.Delete
    Application.DisplayAlerts = True

    ' HTML dosyasını okumak için FileSystemObject kullanın
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set htmlFile = fso.OpenTextFile(dosyaYolu, 1, False, 0) ' 0, dosyayı UTF-8 olarak açar
    htmlContent = htmlFile.ReadAll
    htmlFile.Close

    ' Outlook mail oluşturma
    Set objOutlook = CreateObject("Outlook.Application")
    Set objMail = objOutlook.CreateItem(0)

    ' Mail içeriğine HTML formatında Unicode veriyi ekleyin
    With objMail
        .To = "test@test.com.tr"
        .Subject = "Vadesi gelen/yaklaşan kredi/krediler"
        .HTMLBody = htmlContent ' HTML dosyası içeriği buraya ekleniyor
        '.Attachments.Add dosyaYolu ' Rapor.htm ek olarak gönderilebilir
        .Display ' E-postayı görüntüle (veya .Send ile gönder)
    End With

    ' Temizlik
    Set objMail = Nothing
    Set objOutlook = Nothing

    ' Dosya var mı kontrolü
    If Dir(dosyaYolu) <> "" Then
        Kill dosyaYolu ' Eğer dosya varsa, sil
    End If

    ' Filtreyi kaldır
    ActiveSheet.AutoFilterMode = False

    ' Sonuçları geri döndür
    Sheets("Kredi").Select
    Range("A1").Select
    Application.CutCopyMode = False
    
    Application.ScreenUpdating = True
End Sub