Excel sayfasını outlook'tan mail gönderme hk.

[gkhn2]

merhabalar

Linkte kullandığım bir Excel dosyası var. Bu Excel sayfanın içindeki verileri pdf olarak maile ekliyor ve outlook'u açıyor.

Benim istediğim sayfadaki seçtiğim alandaki verileri boş outlook iletisine, imzanın üstüne eklemek. Örnekteki gibi A1:K5 aralığını görseldeki gibi eklemesini istiyorum.

Mümkün müdür acaba?

https://dosya.co/l3ta7vbew4il/Kitap3.xlsm.html

 

[gkhn2]

Sub mail_secili_alan()
      Dim wrdEdit
      Dim alan As Range
      
       Set alan = Selection
  
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = ""
       .CC = "atakansafi@safiholding.com.tr;ticarimuhasebe@safikatiyakit.com.tr"
       .BCC = ""
       .Subject = "FİYATLAR HK."
       .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, , True, False
        .Cells(1).PasteSpecial xlPasteFormats, , True, 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

Böyle bir kod buldum ama ben bunu pivotta kullanacağım o yüzden biçimleri kopyalamıyor. Birde imza ile "Merhaba" nın arasına yapıştırmıyor. İletinin en üstüne yapıştırıyor. Bunda düzenleme yapmaya çalıştım fakat beceremedim.

 

[hamitcan]

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

 

[gkhn2]

https://www.rondebruin.nl/win/s1/outlook/bmail2.htm

Teşekkürler üstat. Bendeki kodlar buradan devşirme sanırım. İş görüyor ama 2 sorun devam ediyor.

1- Pivottan kopyaladığım için biçimleri getirmiyor.
2- "Merhaba" ile imzanın arasına yapıştırmıyor.

bunları da çözersem tamamdır.

 

[hamitcan]

Sizin verdiğiniz örnekteki tabloyu denedim biçimli şekilde ekledi. Merhaba kelimesi bence kodun içine gömülür diye düşünüyorum.

 

[gkhn2]

Sizin verdiğiniz örnekteki tabloyu denedim biçimli şekilde ekledi. Merhaba kelimesi bence kodun içine gömülür diye düşünüyorum.

Örnek dosyada anlaşılır olsun diye pivot kullanmadım. Merhaba kelimesini öyle yapabilir ama mantıklı.

 

[hamitcan]

Pivot yaptıktan sonra aldığım görüntü...

 

[gkhn2]

Sorunu buldum

Bu şekilde seçersem;

Böyle yapıştırıyor.

Böyle seçersem;

Böyle yapıştırıyor.

Ben ilk denemedeki gibi kullanmak istiyorum. Yani arada boş satırlar, hücreler olacak. Başlık gibi yani onuda yapıştırsın istiyorum.

 

[hamitcan]

Ben de seçimle ilgili olduğunu düşünüyorum. Biraz baktım ama çözemedim. Biraz daha araştıralım bakalım.

 

[hamitcan]

   Set rng = Selection.SpecialCells(xlCellTypeVisible)

kod satırını aşağıdaki ile değiştirip dener misiniz ?

    Set rng = Selection

 

[Asri]

Alternatif;

Bu kod ile özet tablo, filtrelide olsa biçimli olarak maile dahil ediyor.
Tek sorun, imza kısmı gelmiyor. Bu konuda çalışılabilir.
Seçilen alan a kolonuna görer son satır ve 4. satıra göre son sütun tespit edilerek belirleniyor.

Sub due()
  'https://stackoverflow.com/questions/49163778/copying-range-including-formatting-when-pasting-in-outlook-email-body
    Dim ol As Object 'Outlook.Application
    Dim olEmail As Object 'Outlook.MailItem
    Dim olInsp As Object 'Outlook.Inspector
    Dim wd As Object 'Word.Document
    Dim rCol As Collection, r As Range, i As Integer

     '/* if outlook is running use GO, create otherwise */
    Set ol = GetObject(Class:="Outlook.Application")
    Set olEmail = ol.CreateItem(0) 'olMailItem

    sonsatir = Cells(Rows.Count, "A").End(3).Row
    sonsutun = Cells(4, Columns.Count).End(xlToLeft).Column
   
    Set rCol = New Collection
    With rCol
        .Add Range(Cells(1, 1), Cells(sonsatir, sonsutun)) '/* add your ranges the same sequence */
    End With

    With olEmail
       .To = ""
       .CC = "asriakdeniz@gmail.com"
       .BCC = ""
       .Subject = "FİYATLAR HK."
       .Display
       .HTMLBody = "<html><body style=""font-family:calibri"">" & _
                    "<p><b> Merhaba" & "</p></body></html>"
          
        Set olInsp = .GetInspector
        If olInsp.EditorType = 4 Then 'olEditorWord
            Set wd = olInsp.WordEditor
            For i = 1 To rCol.Count '/* iterate all ranges */
                Set r = rCol.Item(i): r.Copy
                wd.Range.InsertParagraphAfter
                wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
                '16 - wdFormatOriginalFormatting
            Next
        End If
        wd.Range.InsertParagraphAfter
        wd.Paragraphs(wd.Paragraphs.Count).Range.Text = ""
        wd.Paragraphs.Last.Range.Sentences.Last.Font.Bold = True
                    
    End Wit

End Sub

 

[gkhn2]

Alternatif;

Bu kod ile özet tablo, filtrelide olsa biçimli olarak maile dahil ediyor.
Tek sorun, imza kısmı gelmiyor. Bu konuda çalışılabilir.
Seçilen alan a kolonuna görer son satır ve 4. satıra göre son sütun tespit edilerek belirleniyor.

Sub due()
  'https://stackoverflow.com/questions/49163778/copying-range-including-formatting-when-pasting-in-outlook-email-body
    Dim ol As Object 'Outlook.Application
    Dim olEmail As Object 'Outlook.MailItem
    Dim olInsp As Object 'Outlook.Inspector
    Dim wd As Object 'Word.Document
    Dim rCol As Collection, r As Range, i As Integer

     '/* if outlook is running use GO, create otherwise */
    Set ol = GetObject(Class:="Outlook.Application")
    Set olEmail = ol.CreateItem(0) 'olMailItem

    sonsatir = Cells(Rows.Count, "A").End(3).Row
    sonsutun = Cells(4, Columns.Count).End(xlToLeft).Column
  
    Set rCol = New Collection
    With rCol
        .Add Range(Cells(1, 1), Cells(sonsatir, sonsutun)) '/* add your ranges the same sequence */
    End With

    With olEmail
       .To = ""
       .CC = "asriakdeniz@gmail.com"
       .BCC = ""
       .Subject = "FİYATLAR HK."
       .Display
       .HTMLBody = "<html><body style=""font-family:calibri"">" & _
                    "<p><b> Merhaba" & "</p></body></html>"
         
        Set olInsp = .GetInspector
        If olInsp.EditorType = 4 Then 'olEditorWord
            Set wd = olInsp.WordEditor
            For i = 1 To rCol.Count '/* iterate all ranges */
                Set r = rCol.Item(i): r.Copy
                wd.Range.InsertParagraphAfter
                wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
                '16 - wdFormatOriginalFormatting
            Next
        End If
        wd.Range.InsertParagraphAfter
        wd.Paragraphs(wd.Paragraphs.Count).Range.Text = ""
        wd.Paragraphs.Last.Range.Sentences.Last.Font.Bold = True
                   
    End Wit

End Sub

aynen hocam bu da süper kod. sadece outlook imzası gelmiyor. zaten önceki kodda da gelmiyor artık. ne olduysa bi excelde geliyor diğerinde gelmiyor. çözemedim.

 

[gkhn2]

   Set rng = Selection.SpecialCells(xlCellTypeVisible)

kod satırını aşağıdaki ile değiştirip dener misiniz ?

    Set rng = Selection

yok yine olmadı bu
https://dosya.co/0qxto4azkyp6/GÜNLÜK_FİYAT_TEYİT_v02.xlsm.html

 

[gkhn2]

Alternatif;

Bu kod ile özet tablo, filtrelide olsa biçimli olarak maile dahil ediyor.
Tek sorun, imza kısmı gelmiyor. Bu konuda çalışılabilir.
Seçilen alan a kolonuna görer son satır ve 4. satıra göre son sütun tespit edilerek belirleniyor.

Sub due()
  'https://stackoverflow.com/questions/49163778/copying-range-including-formatting-when-pasting-in-outlook-email-body
    Dim ol As Object 'Outlook.Application
    Dim olEmail As Object 'Outlook.MailItem
    Dim olInsp As Object 'Outlook.Inspector
    Dim wd As Object 'Word.Document
    Dim rCol As Collection, r As Range, i As Integer

     '/* if outlook is running use GO, create otherwise */
    Set ol = GetObject(Class:="Outlook.Application")
    Set olEmail = ol.CreateItem(0) 'olMailItem

    sonsatir = Cells(Rows.Count, "A").End(3).Row
    sonsutun = Cells(4, Columns.Count).End(xlToLeft).Column
  
    Set rCol = New Collection
    With rCol
        .Add Range(Cells(1, 1), Cells(sonsatir, sonsutun)) '/* add your ranges the same sequence */
    End With

    With olEmail
       .To = ""
       .CC = "asriakdeniz@gmail.com"
       .BCC = ""
       .Subject = "FİYATLAR HK."
       .Display
       .HTMLBody = "<html><body style=""font-family:calibri"">" & _
                    "<p><b> Merhaba" & "</p></body></html>"
         
        Set olInsp = .GetInspector
        If olInsp.EditorType = 4 Then 'olEditorWord
            Set wd = olInsp.WordEditor
            For i = 1 To rCol.Count '/* iterate all ranges */
                Set r = rCol.Item(i): r.Copy
                wd.Range.InsertParagraphAfter
                wd.Paragraphs(wd.Paragraphs.Count).Range.PasteAndFormat 16
                '16 - wdFormatOriginalFormatting
            Next
        End If
        wd.Range.InsertParagraphAfter
        wd.Paragraphs(wd.Paragraphs.Count).Range.Text = ""
        wd.Paragraphs.Last.Range.Sentences.Last.Font.Bold = True
                   
    End Wit

End Sub

bu baya iyiymiş seçim yapmana da gerek yok dediğin gibi.
bir tek imza olayı kaldı bir usta yardımcı oldu mu tamamdır.

 

[Korhan Ayhan]

Merhaba,

Bende konuyu biraz araştırdım. Netten bulduğum kodları sizin dosyanıza göre revize ettim.

Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet, FSO As Object, Sayfa_Adi As String
    Dim Tablo As Variant, Dosya As Object, Son_Satir As Long, WF As WorksheetFunction
    Dim Ozet_Tablo As PivotTable, Yol As String, My_Outlook As Object, My_Mail As Object
   
    Application.ScreenUpdating = False
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("PİVOT")
    Set WF = WorksheetFunction
       
    S1.Select
    Cells.EntireColumn.AutoFit
    ActiveSheet.PivotTables("PivotTable2").PivotSelect "", xlDataAndLabel, True
    Selection.Copy

    Workbooks.Add
    ActiveSheet.Paste
    For Each Ozet_Tablo In ActiveSheet.PivotTables
        Ozet_Tablo.TableStyle2 = "PivotStyleDark14"
        Ozet_Tablo.PivotSelect "'Column Grand Total'", xlDataAndLabel, True
        With Selection.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
    Next
    Range("A1").Select
    Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False
   
    Son_Satir = Cells(Rows.Count, 1).End(3).Row + 5
   
    Set K2 = ActiveWorkbook
   
    If Application.LanguageSettings.LanguageID(msoLanguageIDUI) = "1055" Then
        Sayfa_Adi = "Sayfa1"
    Else
        Sayfa_Adi = "Sheet1"
    End If
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    FSO.CreateTextFile (Yol & "\Test.html")
    K2.PublishObjects.Add(xlSourceRange, Yol & "\Test.html", Sayfa_Adi, K2.Sheets(1).UsedRange.Address, xlHtmlStatic).Publish (True)
    Set Dosya = FSO.OpenTextFile(Yol & "\Test.html")
    Tablo = Dosya.ReadAll
   
    Set My_Outlook = CreateObject("Outlook.Application")
    Set My_Mail = My_Outlook.CreateItem(0)
   
    With My_Mail
        .To = S1.Range("L2").Value
        .CC = S1.Range("M2").Value
        .BCC = ""
        .Subject = S1.Range("B1").Value & " - " & S1.Range("B2").Value & " FİYATLAR HK."
        .Display
        .HTMLBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & "Merhaba," & "<Br><Br>" & "Fiyatları teyit edip, eksikleri bildirmenizi rica ederiz." & "<Br><Br>" & _
                    "<Table Align=Left>" & Tablo & "</Table>" & WF.Rept("<Br>", Son_Satir) & "</Font>" & .HTMLBody
    End With
   
    K2.Close 0
    Dosya.Close
    Range("A1").Select
    Kill (Yol & "\Test.html")
   
    Set FSO = Nothing
    Set Dosya = Nothing
    Set My_Outlook = Nothing
    Set My_Mail = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set WF = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Mail oluşturulmuştur. Kontrol edip gönderebilirsiniz!", vbInformation
End Sub

 

[gkhn2]

Merhaba,

Bende konuyu biraz araştırdım. Netten bulduğum kodları sizin dosyanıza göre revize ettim.

Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, K2 As Workbook, S1 As Worksheet, FSO As Object, Sayfa_Adi As String
    Dim Tablo As Variant, Dosya As Object, Son_Satir As Long, WF As WorksheetFunction, Baslik As String
    Dim Ozet_Tablo As PivotTable, Yol As String, My_Outlook As Object, My_Mail As Object
   
    Application.ScreenUpdating = False
   
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets("PİVOT")
    Set WF = WorksheetFunction
       
    S1.Select
    Cells.EntireColumn.AutoFit
    ActiveSheet.PivotTables("PivotTable2").PivotSelect "", xlDataAndLabel, True
    Selection.Copy

    Workbooks.Add
    ActiveSheet.Paste
    For Each Ozet_Tablo In ActiveSheet.PivotTables
        Ozet_Tablo.TableStyle2 = "PivotStyleDark14"
        Ozet_Tablo.PivotSelect "'Column Grand Total'", xlDataAndLabel, True
        With Selection.Font
            .ThemeColor = xlThemeColorDark1
            .TintAndShade = 0
        End With
    Next
    Range("A1").Select
    Cells.EntireColumn.AutoFit
    Application.CutCopyMode = False
   
    Son_Satir = Cells(Rows.Count, 1).End(3).Row + 5
   
    Set K2 = ActiveWorkbook
   
    If Application.LanguageSettings.LanguageID(msoLanguageIDUI) = "1055" Then
        Sayfa_Adi = "Sayfa1"
        Baslik = "İleti (HTML)"
    Else
        Sayfa_Adi = "Sheet1"
        Baslik = "Message (HTML)"
    End If
   
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
    FSO.CreateTextFile (Yol & "\Test.html")
    K2.PublishObjects.Add(xlSourceRange, Yol & "\Test.html", Sayfa_Adi, K2.Sheets(1).UsedRange.Address, xlHtmlStatic).Publish (True)
    Set Dosya = FSO.OpenTextFile(Yol & "\Test.html")
    Tablo = Dosya.ReadAll
   
    Set My_Outlook = CreateObject("Outlook.Application")
    Set My_Mail = My_Outlook.CreateItem(0)
   
    With My_Mail
        .To = S1.Range("L2").Value
        .CC = S1.Range("M2").Value
        .BCC = ""
        .Subject = S1.Range("B1").Value & " - " & S1.Range("B2").Value & " FİYATLAR HK."
        .Display
        .HTMLBody = "<font style=""font-family: Calibri; font-size: 11pt;""/font>" & "Merhaba," & "<Br><Br>" & "Fiyatları teyit edip, eksikleri bildirmenizi rica ederiz." & "<Br><Br>" & _
                    "<Table Align=Left>" & Tablo & "</Table>" & WF.Rept("<Br>", Son_Satir) & "</Font>" & .HTMLBody
    End With
   
    K2.Close 0
    Dosya.Close
    Range("A1").Select
    Kill (Yol & "\Test.html")
   
    Call AppActivate("Microsoft Excel")

    Set FSO = Nothing
    Set Dosya = Nothing
    Set My_Outlook = Nothing
    Set My_Mail = Nothing
    Set S1 = Nothing
    Set K1 = Nothing
    Set K2 = Nothing
    Set WF = Nothing
   
    Application.ScreenUpdating = True
   
    MsgBox "Mail oluşturulmuştur. Kontrol edip gönderebilirsiniz!", vbInformation

    Call AppActivate("11.04.2019 - Özden Ünal FİYATLAR HK. - " & Baslik)
End Sub

teşekkür ederim fakat aşağıdaki komutta hata verdi.

Call AppActivate("Microsoft Excel")

 

[Korhan Ayhan]

Üstteki mesajımdaki kodu revize ettim. Tekrar deneyiniz.

 

[gkhn2]

Üstteki mesajımdaki kodu revize ettim. Tekrar deneyiniz.

Tamamdır şimdi oldu teşekkürler.

 

[HALILİBRAHIM]

Merhaba arkadaşlar, buradan aldığım yardımlarla excel mail gönderme macrosunu bir yere kadar getirdim. Sheet1 sayfasındaki satırlardan oluşan verileri, send sayfasında 9. satırda ilgili yerlere for dögüsü ile sırası ile yenileyerek yani dinamik bir alan yaparak göndermek istiyorum 9. satırda ise göreceksiniz G ve I sütununa denk gelen hücreler boş kalacak. Ve Sheet sayfasında da gönderildi yazdırmak istiyorum. Ama döngü içinden çıkamadım ve maili gönderemiyorum. Excel dosyamı paylaşmak istiyorum yardımcı olursanız çok teşekkür ederim.

Excel indirme linki : https://sendgb.com/ZRDXg7Kca6C