• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Excelden mail gönderme

E

efsanevi

Katılım
30 Mart 2013
Mesajlar
11
Excel Vers. ve Dili
2013 TÜRKÇE
Arkadaşlar merhaba, Excelde yazdırma alanı olarak seçili alanı buton üzerinden mail göndermek istiyorum, yardımlarınız için şimdiden teşekkürler.
 

Ekli dosyalar

Bu kod ile gönderim yapabilirsiniz.
Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.

Kod: 
Sub mail_gonder()
      Dim wrdEdit
      Dim alan As Range
      sonsatir = Cells(Rows.Count, "A").End(3).Row
      Set alan = Range("A1:K50")
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = Range("P18")
       .CC = Range("P19")
       .Subject = Range("P17")
       .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-2016
    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
 
Sayın Asri hocam,
Teşekkürler
İyi çalışmalar
 
Büyük ve resim eklenmiyor

Asri hocam mail işlemini senin sayende hallettik, şimdiki sıkıntı mailde çok büyük sayfa çıkıyor ve resimi göstermiyor.
 

Ekli dosyalar

efsanevi' Alıntı:
Asri hocam mail işlemini senin sayende hallettik, şimdiki sıkıntı mailde çok büyük sayfa çıkıyor ve resimi göstermiyor.
Genişletmek için tıkla ...

Bu durumda maili resim olarak göndermeniz gerekecektir.

Kod: 
Private Sub CommandButton1_Click()
Sayfa2.PrintPreview
End Sub

Private Sub CommandButton2_Click()
Sayfa2.PrintOut
MsgBox "Satın Alma Teklif Formu Yazıcıya Gönderildi.", vbInformation
End Sub


Sub mail_gonder()
      Dim wrdEdit
      Dim alan As Range
      sonsatir = Cells(Rows.Count, "A").End(3).Row
      Set alan = Range("A1:K50")
      Range("A1:K50").Select
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = Range("P18")
       .CC = Range("P19")
       .Subject = Range("P17")
       .Display
       
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send
       '.HTMLBody = RangetoHTML(alan) & .HTMLBody
         .BodyFormat = 2
          Set wrdEdit = OutApp.ActiveInspector.WordEditor
          Selection.CopyPicture xlPrinter, xlPicture
          wrdEdit.Application.Selection.Paste
          
       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-2016
    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

Private Sub CommandButton3_Click()
Call mail_gonder
End Sub
 
anladım bu şekilde işime yaramıyor, peki asri hocam diğerinde boyutunu küçültebiliyor muyuz? mailden karşı taraf çıktı alacak çok büyük gözüküyor
 
efsanevi' Alıntı:
anladım bu şekilde işime yaramıyor, peki asri hocam diğerinde boyutunu küçültebiliyor muyuz? mailden karşı taraf çıktı alacak çok büyük gözüküyor
Genişletmek için tıkla ...

Karış taraf yazıcıdan çıktı alacak ise resim olarak göndererek tek sayfada çıktı almasını sağlamış olursunuz.
 
asri' Alıntı:
Karış taraf yazıcıdan çıktı alacak ise resim olarak göndererek tek sayfada çıktı almasını sağlamış olursunuz.
Genişletmek için tıkla ...

Hocam resim olarak outlooktan yazdır dediğimde sayfanın tümünü almıyor, ancak resmi farklı kaydedip öyle almak gerekecek. Ayrıca resim formatında iken altta bulunan imzam da görünmüyor.
 
efsanevi' Alıntı:
Hocam resim olarak outlooktan yazdır dediğimde sayfanın tümünü almıyor, ancak resmi farklı kaydedip öyle almak gerekecek. Ayrıca resim formatında iken altta bulunan imzam da görünmüyor.
Genişletmek için tıkla ...

Excel de görünümü %100 fontu 10 yada 9 yapın sütunları ve satırları daraltarak formu küçültmeye çalışın. Mail gönder yaparak kontrol edin.

Bu şekilde bir sayfaya sığacak şekilde yeniden düzenleyin.
Excel de formu çok büyük kullandığınız için mail e de büyük gelmektedir.
 
Asri' Alıntı:
Bu kod ile gönderim yapabilirsiniz.
Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.

Kod: 
Sub mail_gonder()
      Dim wrdEdit
      Dim alan As Range
      sonsatir = Cells(Rows.Count, "A").End(3).Row
      Set alan = Range("A1:K50")
          
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = Range("P18")
       .CC = Range("P19")
       .Subject = Range("P17")
       .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-2016
    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 ...

Sayın @Asri iyi forumlar.
Kusura bakmayın konuyu hortlatmış bulunuyorum.

Paylaşmış olduğunuz kodu kullanmaktayım. Belirli bir alanı mail olarak gönderimi yapabiliyorum.
2 husus var takıldığım.

1.si
'.send işlevini aktif yapıyorum. Gönderim gerçekleşmiyor ekrana hata geliyor.

2.si
Outlook programı hiç açılmamışsa eğer; (otomatik send aktif değil)
Makro ile gönderim çalışınca ekrana maili yazma ekranı açılıyor. İçinde kopyalanan/gönderilecek olan veriler var.
Gönder'e basıyorum gönderilmiş gibi gözüküyor ama göndermiyor. Ta ki outlook programını açana kadar.
Programı açınca gönderilenler kutusunda biriken mailler hemen gidiyor.

Yukarıdaki kod dizinine outlook uygulamasının gönderimden önce arka planda açılması eklenebilir mi?

Teşekkür ederim.
 
Gönderim öncesi outlook u bir defa açmak için bu kodu kullanabilirsiniz.
Açma sonrası gönderimlerinizi yaparsınız.

Kod: 
'https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba'
Sub outlok_ac()

Dim oOutlook As Object

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
    Shell ("OUTLOOK")
    Application.Wait Now + TimeSerial(0, 0, 3)
Else
    'already open
End If

End Sub
 
Hocam kafama takıldı send komutu yerine hazırlanmış gönderi penceresi gelebilir mi?
C++: 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = emailAddress
        .CC = ""
        .BCC = ""
        .Subject = dosya_adi
        .Body = dosya_adi & " ektedir."
        .Attachments.Add SavePath
        .Send
    End With
 
Asri' Alıntı:
Gönderim öncesi outlook u bir defa açmak için bu kodu kullanabilirsiniz.
Açma sonrası gönderimlerinizi yaparsınız.

Kod: 
'https://stackoverflow.com/questions/33328314/how-to-open-outlook-with-vba'
Sub outlok_ac()

Dim oOutlook As Object

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then
    Shell ("OUTLOOK")
    Application.Wait Now + TimeSerial(0, 0, 3)
Else
    'already open
End If

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

Teşekkürler sayın @Asri



yusuf1284' Alıntı:
Hocam kafama takıldı send komutu yerine hazırlanmış gönderi penceresi gelebilir mi?
C++: 
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    With OutMail
        .To = emailAddress
        .CC = ""
        .BCC = ""
        .Subject = dosya_adi
        .Body = dosya_adi & " ektedir."
        .Attachments.Add SavePath
        .Send
    End With
Genişletmek için tıkla ...

13. mesajdaki kodu kullanırsanız send komutu çalışmaz, ekrana gönderi penceresi açılır.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst