Mail gönderiminde imza sorunu

[cavanoos]

Merhaba;

Alttaki kod ile excel üzerinden mail gönderimi yapabiliyorum.Ama mailde tanımlanan imzayı getirmiyor.Alttaki ikinci kod örneğinde ise mail gönderiminde imza geliyor.İkinci kodda ilgili kodları,ilk koda uyarlayabilir miyiz ?

Yardım edebilir misiniz ?


Sub MailGönder()
Dim evnOut As Outlook.Application, evn As Object
Dim evngovde As String, i As Long
For i = 2 To Range("a65536").End(3).Row
Set evnOut = New Outlook.Application
Set evn = evnOut.CreateItem(0)
With evn
.To = Cells(i, "f").Value
.Subject = "Ba Formu Mutabakatı"
evngovde = "Merhaba " & Cells(i, "aa").Value & vbLf & vbLf
evngovde = evngovde & "Mayıs ayı alış tutarlarımız aşağıdaki gibidir." & vbLf
evngovde = evngovde & "Fatura Miktarı " & Cells(i, "d").Value & vbLf
evngovde = evngovde & "Fatura Tutarı " & Cells(i, "e").Value & vbLf
evngovde = evngovde & "Yanıtınızı rica ediyoruz." & vbLf
evngovde = evngovde & "İyi Çalışmalar"
.body = evngovde
'Eğer mailine dosya eklemek istiyorsan alttaki kodu aktif et
'.Attachments.Add ("C:\Users\user\Desktop\Yedek\Mail İmza.jpg")
.Display ' Ekranda gösterir
.Send
End With
Next i
Set evn = Nothing: Set evnOut = Nothing
evngovde = vbNullString: i = Empty
End Sub


İkinci Kod


Sub eposta()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Set rng = Nothing
On Error Resume Next
Set rng = Range("a1:f" & Range("a65536").End(3).Row)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = ""
.CC = ""
.BCC = ""
.Subject = "İFL HK."
.HTMLBody = RangetoHTML(rng) & .HTMLBody
.Send
End With
Set OutMail = Nothing
Set OutApp = Nothing
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.Select
Cells.EntireRow.AutoFit
Cells.EntireColumn.AutoFit
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

 

[Asri]

Mail imzanızı html olarak kaydedin.
Html de imzandan önce @mesaj olarak bir yazı yazın.
Bu değişken olarak kullanıcak.

Aşağıdaki kod ile imzayı yükleyin.
.HTMLBody = htmltext ile de eklediğinizde imzanız görünecektir.

       imzayol = yol & "mailimza.html"
       Set FSO = CreateObject("Scripting.FileSystemObject")
       Set readFile = FSO.OpenTextFile(imzayol, ForReading, False)
       htmltext = readFile.ReadAll
       readFile.Close
       Set readFile = Nothing
       Set FSO = Nothing
       mesajlar = mesaj1 & "<br>" & "<br>" & mesaj2
       htmltext = Replace(htmltext, "@mesaj", mesajlar)
      .HTMLBody = htmltext