Seçili Alanı Mail Atma

ozturk38 · 26 Temmuz 2017

Merhabalar ; Aşağıdaki kodları kullandığımda sayfanın tamamını mail atıyor oysa ben sadece seçtiğim alanı mail atmak istiyorum işin içinden çıkamadım yardımcı olabilirseniz sevinirim.

Set Bul = Range("d:d").Find(Date, Cells(Rows.Count, 4), , xlWhole)
If Not Bul Is Nothing Then
Say = WorksheetFunction.CountIf(Range("d:d"), Date)
Alan = "A" & Bul.Row & ":H" & Bul.Row + Say - 1
Range(Alan & ",A1:H9").Select

End If
Set Rng = Selection.SpecialCells(xlCellTypeVisible)
If Not Bul Is Nothing Then
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope
.Introduction = "Murat Bey" & Chr(13) & Chr(13) & "Bugün ki Ödeme / Tahsilat Planı"
.Item.to = "ozturk_omer_@hotmail.com"
.Item.Subject = Date & " Ödeme / Tahsilat Bildirimi"
.Item.send
End With
Else
MsgBox "Bugüne ait veri bulunamadı!", vbCritical
End If

Korhan Ayhan · 26 Temmuz 2017

Merhaba,

Aşağıdaki linkte bu sorunu irdelemiştik. Oradaki çözüm işinize yaramadı mı?

http://www.excel.web.tr/f48/bugun-tarihli-hucreleri-secili-hale-getirme-t164922.html

ozturk38 · 26 Temmuz 2017

Hocam şöyle o kodları kullanıyorum zaten ama ek olarak alan değişkeni İle Birlikte (A1:H1) aralığınıda eklemek istiyorum örnek tabloyu gönderiyorum hocam.Sadece Seçim yaptığım alanı maile eklemek istiyorum sayfanın tamamını değil.

Asri · 26 Temmuz 2017

Alternatif;

Aşağıdaki kodu kendinize göre uyarlayınız.
Üst bölümdeki resimleri eklemedi.

Kod:

Sub mail_secili_alan()
      Dim wrdEdit
      Dim alan As Range
      
       Set alan = Range("A11:H11", "A1:H9").SpecialCells(xlCellTypeVisible)
   
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = "mailadresi1@isim.com;mailadresi2@isim.com;"
       .CC = ""
       .BCC = ""
       .Subject = "mail konu"
       .Display
       
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send
       .HTMLBody = RangetoHTML(alan) & .HTMLBody
       End With
      
      Set wrdEdit = Nothing
      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

Murat OSMA · 26 Temmuz 2017

Excelde Outlook üzerinden mail gönderme ile ilgili daha kaç kez konu açılacak hayretler içinde takip ediyorum.
Çoğu zaman son 30 mesaj içerisinde aynı konuda destek talep ediliyor.
Üyelerin yeni bir konu açmadan önce son 30 mesaj tablosuna bakmalarını, orada yoksa site içerisinde arama yapmalarını ve bu konuda daha özenli davranmalarını sağlamak gerekiyor.

Asri · 26 Temmuz 2017

Murat OSMA' Alıntı:
Excelde Outlook üzerinden mail gönderme ile ilgili daha kaç kez konu açılacak hayretler içinde takip ediyorum.
Çoğu zaman son 30 mesaj içerisinde aynı konuda destek talep ediliyor.
Üyelerin yeni bir konu açmadan önce son 30 mesaj tablosuna bakmalarını, orada yoksa site içerisinde arama yapmalarını ve bu konuda daha özenli davranmalarını sağlamak gerekiyor.

Yorumum genel, konuyu açan ile ilgili değildir;
Sorun, talepte bulunanların arama yapıp yapmamaları değil. Arama yapsalar bile istedikleri formatın aynısı olmayınca yeni konu açılıyor diye düşünüyorum.
Belki bulduğu örnek kod yada dosya üzerinden, bulduğu kod üzerinde çalışma yapamayacak kadar bilgi sahibi olmayanlar hariç, diğerleri biraz daha çalışsa hem bir şeyler öğrenecek hem de forum gereksiz yere meşgul edilmeyecektir.

ozturk38 · 26 Temmuz 2017

Hocam makro konusunda bilgi sahibi değilim iş yerim için bişeyler yapmaya çalışıyorum. açtığım konu ile alakalı olarak H11 e kadar olan sabit değil bugünün tarihine denk gelen ödemeleri mail atmak istiyorum.

Asri · 26 Temmuz 2017

ozturk38' Alıntı:
Hocam makro konusunda bilgi sahibi değilim iş yerim için bişeyler yapmaya çalışıyorum. açtığım konu ile alakalı olarak H11 e kadar olan sabit değil bugünün tarihine denk gelen ödemeleri mail atmak istiyorum.

Mesaja dosya eklendi.
Program bugünün tarihine göre süzdükten sonra mail gönderim ekranını getirmektedir.
Gönderim işlemini otomatik yapmak istiyorsanız '.send in başındaki tırnağı kadırın.

ozturk38 · 26 Temmuz 2017

Hocam yordum sizi ama gönderdiğim mail aşağıdaki gibi çıkıyor
Murat Bey

Bugün ki Ödeme / Tahsilat Planı

EURO ÖDEMELER

TL ÖDEMELER

BUGÜNKİ KREDİ ÖDEMELERİ

0,00

2.520,00 ₺

YARINKİ KREDİ ÖDEMELERİ

4.682,00

0,00 ₺

BUGÜNKİ ÇEK ÖDEMELERİ

YARINKİ ÇEK ÖDEMELERİ

BUGÜNKİ ÇEK TAHSİLATI

TARİH

AÇIKLAMA

ÖDEME TÜRÜ

VADE TARİHİ

TUTAR EURO

TUTAR TL

ÖDEME DURUMU

KALAN TAKSİT

26.07.2016

AKBANK MASRAF (GÖKHAN PAKSOY) KREDİ ÖDEMESİ

KREDİ

26.07.2017

2.520,00 ₺

ÖDENMEDİ

13

Asri · 26 Temmuz 2017

ozturk38' Alıntı:
Hocam yordum sizi ama gönderdiğim mail aşağıdaki

Bu şekilde çıkmıyordur ancak siz nasıl çıkmasını umuyordunuz.
Ben test etmiştim. Sadece resm olan logo çıkmıyordu.
Süzülen veri kaç adet ise okadarını ekliyor.

ozturk38 · 26 Temmuz 2017

Hocam gönderirken gönderim ekranında sorun yok excel tablosunda nasıl görünüyorsa öyle ama
gönderdiğim kişide maili açınca yukardaki gibi

ozturk38 · 26 Temmuz 2017

Hocam sebebi neydi bilmiyorum fakat şimdi düzgün istediği şekilde çıkıyor fakat tablomun tamamını gizliyor ya onu görünür hale getiremedim. ben ödeme yaptıkça işaretlediğimi gizlesin istiyorum. hocam ne olur kusura bakmayın fazla istekte bulunmuş olabilirim kusuruma bakmayın.

Asri · 26 Temmuz 2017

ozturk38' Alıntı:
Hocam gönderirken gönderim ekranında sorun yok excel tablosunda nasıl görünüyorsa öyle ama
gönderdiğim kişide maili açınca yukardaki gibi

Gmail maili düzgün almış görünüyor.

Asri · 26 Temmuz 2017

ozturk38' Alıntı:
Hocam sebebi neydi bilmiyorum fakat şimdi düzgün istediği şekilde çıkıyor fakat tablomun tamamını gizliyor ya onu görünür hale getiremedim. ben ödeme yaptıkça işaretlediğimi gizlesin istiyorum. hocam ne olur kusura bakmayın fazla istekte bulunmuş olabilirim kusuruma bakmayın.

Bunu anlamadım. Tablo gizleme yapmıyor. Siz bugünün kayıtlarını göndersin istemiştiniz. Programda bugün için süzme yapıyor.

Tüm kayıtları görmek istiyorsanız süzmeyi kaldırın.

Asri · 26 Temmuz 2017

Mail gönderirken aynı gün ve sadece ÖDENMEDİ leri göndermek için aşağıdaki kodu güncelleyin.

Tabloda ÖDENDEN lerin bilgisini de ÖDENDİ olarak güncelleyin.

Kod:

Private Sub CommandButton5_Click()
  ActiveSheet.ListObjects("Tablo1").Range.AutoFilter
  ActiveSheet.ListObjects("Tablo1").Range.AutoFilter Field:=4, Criteria1:=xlFilterToday, Operator:=xlFilterDynamic
  ActiveSheet.ListObjects("Tablo1").Range.AutoFilter Field:=7, Criteria1:="ÖDENMEDİ"
        
  satir = CountVisibleRows(0)
  If satir <= 8 Then
     MsgBox "Bugüne ait veri bulunamadı!", vbCritical
  Else
     Call mail_gonder
  End If
  ActiveSheet.ListObjects("Tablo1").Range.AutoFilter
End Sub

ozturk38 · 26 Temmuz 2017

Çok teşekkür ederim Elinize sağlık.

ozturk38 · 26 Temmuz 2017

Hocam maillerin karşı tarafa bozuk gitme sebebi nedir çözemedim sorun halen devam ediyor hotmail güvenlik sebebinden dolayı diye bir uyarı veriyordu. başka neden olur çözemedim.

Asri · 26 Temmuz 2017

ozturk38' Alıntı:
Hocam maillerin karşı tarafa bozuk gitme sebebi nedir çözemedim sorun halen devam ediyor hotmail güvenlik sebebinden dolayı diye bir uyarı veriyordu. başka neden olur çözemedim.

Sizin outlook ile ilgili belki mail imzanız ile ilgili birşey olabilir bilemiyorum.
Ben gmail e gönderdiğimde ve outlook giden kutusunda iken bir sorun göremedim.

denese · 15 Şubat 2018

asri' Alıntı:

Alternatif;

Aşağıdaki kodu kendinize göre uyarlayınız.
Üst bölümdeki resimleri eklemedi.

Kod:

Sub mail_secili_alan()
      Dim wrdEdit
      Dim alan As Range
      
       Set alan = Range("A11:H11", "A1:H9").SpecialCells(xlCellTypeVisible)
   
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = "mailadresi1@isim.com;mailadresi2@isim.com;"
       .CC = ""
       .BCC = ""
       .Subject = "mail konu"
       .Display
       
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send
       .HTMLBody = RangetoHTML(alan) & .HTMLBody
       End With
      
      Set wrdEdit = Nothing
      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

Merhaba Sn. Asri,

Vade tarihi bugün olanları değil de, tanımlanan iki tarih aralığında olanları göndermek istediğimizde;

Aktif çalışma sayfasında olmak üzere;
Filtre başlangıç tarihi : K1
Filtre bitiş tarihi (dahil) : K2

olduğunu varsayarsak, kodu nasıl revize etmemiz gerekir?

Huzur dolu günler dilerim.

ottoman005 · 5 Nisan 2024

Run time 2147221238 (8004010a) Otomasyon hatası alıyorum
0.6 KBGörüntüleme: 32
Beğen Alıntı CevaplaŞikayet Et!
Asri
Asri
26 Temmuz 2017
Add bookmark
#4
Alternatif;

Aşağıdaki kodu kendinize göre uyarlayınız.
Üst bölümdeki resimleri eklemedi.

Kod:
Sub mail_secili_alan()
Dim wrdEdit
Dim alan As Range

Set alan = Range("A11:H11", "A1:H9").SpecialCells(xlCellTypeVisible)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "mailadresi1@isim.com;mailadresi2@isim.com;"
.CC = ""
.BCC = ""
.Subject = "mail konu"
.Display

'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
'.send
.HTMLBody = RangetoHTML(alan) & .HTMLBody
End With

Set wrdEdit = Nothing
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

ublishsource=", _
"align=left x

ublishsource=")

'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

İnternetten araştırdım şunu yazıyor

Run-time error '-2147467259 (80004005)': Method 'MaximumScale' of object 'Axis' failed
Microsoft Excel'de grafiğin özelliğini ayarlayan bir makronuz var. Örneğin, makro grafiğin MaximumScale, MinimumScale, Title, Axis veya Legendproperty değerlerini ayarlar.
Çalışma sayfasını korursunuz. Bunu yaptığınızda, Sayfayı Koru iletişim kutusunda Nesneleri düzenle onay kutusunu tıklayarak seçersiniz.
Makroyu çalıştırırsınız. Sebebi nedir acaba ama bu uyarıyı sendeki tırnağı kaldırınca veriyor kaldırmadan mail açılıp sorunsuz gonderiyor

Seçili Alanı Mail Atma

ozturk38

Korhan Ayhan

Administrator

ozturk38

Ekli dosyalar

Asri

Ekli dosyalar

Murat OSMA

Altın Üye

Asri

ozturk38

Asri

ozturk38

Asri

ozturk38

ozturk38

Asri

Ekli dosyalar

Asri

Asri

ozturk38

ozturk38

Asri

denese

ottoman005