Excelden mail gönderme

efsanevi · 14 Eylül 2017

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.

efsanevi · 15 Eylül 2017

Arkadaşlar ilgilenen var mı ?

Tevfik_Kursun · 15 Eylül 2017

Merhaba,
Asri Akdeniz hocanın çalışmalarına bakınız. ( www.asriakdeniz.com )
İyi çalışmalar

Asri · 15 Eylül 2017

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

Tevfik_Kursun · 16 Eylül 2017

Sayın Asri hocam,
Teşekkürler
İyi çalışmalar

efsanevi · 25 Eylül 2017

Hocam teşekkürler..

efsanevi · 25 Eylül 2017

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.

Asri · 25 Eylül 2017

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.

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

efsanevi · 25 Eylül 2017

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

Asri · 25 Eylül 2017

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

Karış taraf yazıcıdan çıktı alacak ise resim olarak göndererek tek sayfada çıktı almasını sağlamış olursunuz.

efsanevi · 25 Eylül 2017

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

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.

Asri · 25 Eylül 2017

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.

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.

RBozkurt · 14 Ocak 2023

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

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.

Asri · 15 Ocak 2023

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

yusuf1284 · 16 Ocak 2023

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

RBozkurt · 16 Ocak 2023

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

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

13. mesajdaki kodu kullanırsanız send komutu çalışmaz, ekrana gönderi penceresi açılır.

Excelden mail gönderme

efsanevi

Ekli dosyalar

efsanevi

Tevfik_Kursun

Asri

Tevfik_Kursun

efsanevi

efsanevi

Ekli dosyalar

Asri

efsanevi

Asri

efsanevi

Asri

RBozkurt

𐱅𐰇𐰼𐰚

Asri

yusuf1284

RBozkurt

𐱅𐰇𐰼𐰚