mail gönderme

[emrebengul]

İyi günler kolay gelsin arkadaşlar. ben bi makro yazdım tuşa bastığımda mail gönderecek ama bi türlü olmadı yardımcı olur musunuz?

 

[emrebengul]

https://upterabit.com/6b8/IMG-20160814-WA0004.jpg

 

[emrebengul]

https://upterabit.com/6b7/IMG-20160814-WA0003.jpg

 

[pys60]

resim ekelmek için upload sitelerini kullanın ve sorunuzun cevabı sitede mevcut olup arama yaparak erişebilirsiniz

 

[emrebengul]

https://upterabit.com/6b7/IMG-20160814-WA0003.jpg

 

[emrebengul]

https://upterabit.com/6b8/IMG-20160814-WA0004.jpg

 

[bkts34]

To kısmında türkçe karakter kullanmışşınız mail adresinde türkçe karakter olmaz, birde Attachments.Add dedikten sonra dosya adresi belirtmeniz lazım siz sadece dosya adı yazmışsınız buda olmaz, bunları düzeltirseniz olur,

 

[emrebengul]

ben yaptım yine olmadı acaba kodu yazıp gösterir misiniz size zahmet?

 

[bkts34]

Bu kodla olabilir,

Sub mail gönder()
    If ActiveWorkbook.Path <> "" Then
        Set OutApp = CreateObject("Outlook.Application")
        Set Outmail = OutApp.CreateItem(0)
        On Error Resume Next
          With Outmail
            .To = "satisdepartmani@sampa.com"
            .CC = ""
            .Subject = ThisWorkbook.Name
             .Display
            .Attachments.Add ThisWorkbook.FullName
            .Send
        End With
        Set Outmail = Nothing
        Set OutApp = Nothing
    End If
End Sub

 

[bdrymrl]

Sub Mail()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet

Set Sh = ActiveSheet
Set S1 = Sheets("MAIL")

For i = 3 To [MAIL!A65536].End(3).Row
Sh.Range("B2:F2").AutoFilter Field:=5, Criteria1:=S1.Cells(i, "A").Text

With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "BU KISMA MAİL İÇERİSİNDE ÇIKMASINI " & vbNewLine & vbNewLine & _
"İSTEDİĞİNİZ BİR MESAJ VARSA YAZABİLİRSİNİZ" & vbNewLine & _
"" & vbNewLine & _
"" & vbNewLine & _
""
On Error Resume Next
With OutMail
.To = S1.Cells(i, "B")
.CC = ""
.BCC = ""
.Subject = "MAİLİN KONUSUNU BU KISMA YAZABİLİRSİNİZ "
.HTMLBody = strbody & RangetoHTML(rng)
.Send
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Next
End Sub
Function RangetoHTML(rng As Range)
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"
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
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
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
RangetoHTML = ts.ReadAll
ts.Close
RangetoHTML = Replace(RangetoHTML, "align=center xublishsource=", _
"align=left xublishsource=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function

 

[emrebengul]

ikisinide denedim bkts34 sizin ki mail açılıyor hemen kapanıyor? bdrymrl sizinki hiç açılmadı hata verdi

 

[bkts34]

Bende açılıp kapanmıyor veya açılıyor kapanıyor da çok hızlı oluyor ben görmüyorum demekki Ama mail gönderiyor kodda sorun yok yani.

 

[emrebengul]

teşekkürler saolun yardımlarınız için