Çözüldü Excel İçeriğini Outlook Mail E Aktarma

Merhaba,
Yardımcı olabilecek birileri var mıdır?

Syg,

@fledermaus
Forumda mail tablo diye arama yaparsanız ilgili olabilecek konulara erişebilirsiniz.
Örneğin konulardan biri şu:

Ömer BARAN' Alıntı:

@fledermaus
Forumda mail tablo diye arama yaparsanız ilgili olabilecek konulara erişebilirsiniz.
Örneğin konulardan biri şu:

https://www.exceldestek.com/konu/tablo-ve-resim-olarak-mail-gonderme.3987/#post-28037

Genişletmek için tıklayın ...

Hocam Merhaba,

Dosyayı inceledim. Konu benim konuma yakın bir konu ancak benim yapmak istediğim biraz daha farklı.

İncelemiş olduğum dosyada yanlış anlamadıysam outlook a jpeg formatında atıyor. Ancak ben, çalışmış olduğum sayfayı aralığını outlook mail e bir şablon gibi (yazılmış bir mail) göndersin istiyorum. Yani gerekirse üzerinde düzeltme ve ekleme yapabileyim.

Bir de makroda çok iyi olmadığımdan yazılan kodları kendime uyarlama gibi bir şansım yok açıkcası.

Normalde başka bir çalışma kitabında aşağıdaki gibi buna benzer bir işlem için kullanmış olduğum bir kod var ancak bu sadece pdf olarak kayıt edip, mail konusunu da ekleyip sadece mail eki olarak ekleyip açıyor.

Syg,

Sub PDF_KAYDET()
If Range("AX18") = "" Then
MsgBox "Lütfen dosya adını yazınız!", vbCritical
Exit Sub
End If

Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop")
Dosya_Adi = Range("AX18") & ".pdf"

Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Yol & "\" & Dosya_Adi, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

MsgBox "Dosya Masa Üstüne Kayıt Edilmiştir."
End Sub

Sub MAIL_GONDER()
Dim Uygulama As Object
Dim Yeni_Mail As Object

If Range("AX18") = "" Then
MsgBox "Lütfen dosya adını yazınız!", vbCritical
Exit Sub
End If

Yol = ThisWorkbook.Path
Dosya_Adi = Range("AX18") & ".pdf"

Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Yol & "\" & Dosya_Adi, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

Set Uygulama = CreateObject("Outlook.Application")
Set Yeni_Mail = Uygulama.CreateItem(0)

With Yeni_Mail
.Subject = Range("AX14")
.Body = Range("AX21")
.Attachments.Add Yol & "\" & Dosya_Adi
.SAVE
If Range("AX10") = "" Then
.To = ""
.Display
Else
.To = Range("DN17")
.Send
MsgBox "Mail gönderildi."
End If
End With

Set Uygulama = Nothing
Set Yeni_Mail = Nothing
End Sub

Bağlantı adresini verdiğim konudaki cevapta GVD2 (resim ile ilgili kısımlar) ile ilgili kısımları kaldırıp denediniz mi?

Ömer BARAN' Alıntı:

Bağlantı adresini verdiğim konudaki cevapta GVD2 (resim ile ilgili kısımlar) ile ilgili kısımları kaldırıp denediniz mi?

Genişletmek için tıklayın ...

Hocam Merhaba,

Makroyu kendime göre nasıl revize edebilirim beceremedim açıkçası.

Ben email direk göndermek istemiyorum açıkçası.

E-posta gönder e tıkladığımda, email içeriğine

Y1 hücresinde geçen yazıları email konusuna ekleyerek yeni bir email sayfası açsın istiyorum.

Sonrasında göndermek istediğim mail adresini kendim manual olarak yazacağım.

Paylaşmış olduğunuz linkteki kodları revize etmeye çalıştım ancak elime yüzüme bulaştırdım, olmadı yani

Syg,

Hocam Tekrar Merhaba,

Uyguladığım dosya ektedir. Nerde yanlış yapıyorum bulamadım açıkçası.

Makroları çalıştırdığım anda outlook kilitleniyor.

Ayrıca önceden bahsetmiş olduğum gibi epostayı direk göndermek yerine outlook pencereme bilgiler aktarıldıktan sonra

mail adresini ben yazayım istiyorum. Ve birde mail talebi ve içeriği eklemek. Kodları nasıl revize etmeliyim ?

Sub eposta()

Dim Alan As Range
Dim daralan As Range

With Application
.ScreenUpdating = False
.EnableEvents = False
End With
DinamikAlan = "A1:J46"
Set Alan = Worksheets("brief").Range(DinamikAlan)
Set sayfa = ActiveSheet
With Alan
.Parent.Select
Set daralan = ActiveCell
.Select
ActiveWorkbook.EnvelopeVisible = True
With .Parent.MailEnvelope
With .Item
.To = "[email protected]"
.Subject = "Y1"
.Bcc = ""
.Send
End With
End With
daralan.Select
End With
sayfa.Select
With Application
.ScreenUpdating = True
.EnableEvents = True
End With


End Sub



Syg

Roma'yı yeniden fethetmeye gerek yok.
Sitede nerden baksanız 50 taneye yakın Excel üzerinden E-Posta yollamaya yarayan dosya bulunmaktadır.
Kolay arama olması nedeniyle ExcelDepo üzerindeki bazı linkleri ekledim.

Bu dosyaların çoğu burada da mevcut, indirip biraz üzerinde durmalısınız

Merhaba,

Dosyam için az önce eklediğim ve kullandığım kod aşağıdaki gibidir. Her şey dosdoğru çalışıyor.

Sadece mail açıldığında eklenen Range("A1:K50") alanın üzerine araya boşluk vererek P13:U16 alanında oluşturacağım ve mail için hazırlamış olduğum başlık yazı dizisi gelsin istiyorum.

Bunun için kodlama da nasıl bir revizyon yapmalıyım ? Birde aradaki boşluğu ayarlayabilmek için kodlama da nereyi değiştirmeliyim.


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
.Subject = Range("Y1")
.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

Emojiler için kusura bakmayın. Kodların kopyalandığında bu şekile döneceğini bilemedim.

Yanlış anlaşılmasın lütfen.

Syg,

Merhaba,

Kodlar aşağıdaki gibi düzeltildi.

Uygulanmış dosya ekteki gibidir.



Syg

Merhaba,

Bu konu ile ilgili paylaşmış olduğum dosyamda ("P3:W16") alanını DATA isimli bir başka çalışma sayfası açarak ("B1:O1") hücre aralığına taşıdım.

Yukarıda paylaşmış olduğum kodu "Set alan1 = Range("P3:W16")" ise aşağıdaki gibi değiştirdim ancak çalışmadı.


Set alan1 = Application.(ActiveWorkbook.Sheets("DATA").Range("B1:O1"))

Makroda yeni olduğum ve aynı çalışma kitabında başka bir çalışma sayfasında geçen hücre kodlamasına çok aşina olmadığımdan kodlama hatası yaptığımı düşünüyorum.

Nasıl bir düzeltme yapmam gerekli ? Yardımcı olabilirseniz sevinirim.

Syg,










Syg,

Merhaba,

Yardımcı olabilecek birileri var mıdır ?

Syg,

Merhaba,

Yardımcı olabilecek birileri var mıdır?

Syg

Konuyu kendim çözdüm teşekkürler.

Ekipteki herkesin bir şekilde konuya dahil olabilmesi için öncelikle zaman, daha sonra ise istenilenin bilgi dağarcığında olması gerekir. Sorunuzda demek ki bu şartlar bir türlü sağlanamamış. En iyi öğrenme yöntemi de kişinin çözümünü kendi bulmuş olmasıdır. Bu sebeple sizi tebrik ederim.

"bilgimiz dahilinde" olan sorularda görüşmek üzere, iyi çalışmalar,