vba ile outlook maillerine nasıl imza eklenir

[aksoyolgun]

merhabalar
aşağıdaki macro ile mail gönderebiliyorum fakat imza ekleyemiyorum
bu makroya nasıl outlooktaki imzanın aynısını ekleyebilirim.
yardımlarınız için çok tşkler


Sub mail_gönderme()

Dim Mail As Object
Set Makro = CreateObject("Outlook.Application")
Set Mail = Makro.CreateItem(0)
On Error Resume Next

ActiveSheet.Copy

ChDir "C:\Users\olgun.aksoy\Pictures\Desktop\listeler-gönderilen"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\olgun.aksoy\Pictures\Desktop\listeler-gönderilen\liste-" & Format(Date, "yyyy/mm/dd") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


With Mail
.To = "olgun.aksoy@şirketadı.com"
.CC = ""
.Subject = Format(Date, "yyyy/mm/dd") & " " & "tarihli liste"

.Body = "bilgi" _
& vbNewLine & "bilgi" _
& vbNewLine & "bilgi" _
& vbNewLine & "İyi çalışmalar dilerim" _



.Attachments.Add ActiveWorkbook.FullName
.Send
End With

On Error GoTo 0
Set Mail = Nothing
Set Makro = Nothing

MsgBox "Mail gönderildi"
End Sub

 

[turist]

Aşağıdaki kodu deneyin.

Sub mail_gönderme()
  Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
ActiveSheet.Copy

ChDir "C:\Users\olgun.aksoy\Pictures\Desktop\listeler-gönderilen"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\olgun.aksoy\Pictures\Desktop\listeler-gönderilen\liste-" & Format(Date, "yyyy/mm/dd") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


body = "<H3><B> Sayın Bilgi.....</B></H3>" & _
              "Bilgiiiiiiiiiiiiiiiiiiii.<br>" & _
              "Biiiiilgggggiiiiiiiiiiiiiiiii.<br>" & _
               "<br><br><B>İyi çalışmalar dilerim</B>"

  

    With OutMail
        .Display
.To = "olgun.aksoy@şirketadı.com"
.CC = ""
.Subject = Format(Date, "yyyy/mm/dd") & " " & "tarihli liste"
.HTMLBody = body & "<br>" & .HTMLBody


.Attachments.Add ActiveWorkbook.FullName
.Display ' Göndermeden görmek istemezeniz Displayin başına tırnak koyunuz
'.Send 'Direkt göndermek için Sendin başındaki tıranğı kaldırın.
End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
MsgBox "Mail gönderildi"
End Sub

 

[aksoyolgun]

Aşağıdaki kodu deneyin.

Sub mail_gönderme()
  Dim OutApp As Object
    Dim OutMail As Object
    Dim strbody As String
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
ActiveSheet.Copy

ChDir "C:\Users\olgun.aksoy\Pictures\Desktop\listeler-gönderilen"
ActiveWorkbook.SaveAs Filename:= _
"C:\Users\olgun.aksoy\Pictures\Desktop\listeler-gönderilen\liste-" & Format(Date, "yyyy/mm/dd") & ".xlsx" _
, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False


body = "<H3><B> Sayın Bilgi.....</B></H3>" & _
              "Bilgiiiiiiiiiiiiiiiiiiii.<br>" & _
              "Biiiiilgggggiiiiiiiiiiiiiiiii.<br>" & _
               "<br><br><B>İyi çalışmalar dilerim</B>"

 

    With OutMail
        .Display
.To = "olgun.aksoy@şirketadı.com"
.CC = ""
.Subject = Format(Date, "yyyy/mm/dd") & " " & "tarihli liste"
.HTMLBody = body & "<br>" & .HTMLBody


.Attachments.Add ActiveWorkbook.FullName
.Display ' Göndermeden görmek istemezeniz Displayin başına tırnak koyunuz
'.Send 'Direkt göndermek için Sendin başındaki tıranğı kaldırın.
End With
    On Error GoTo 0
    Set OutMail = Nothing
    Set OutApp = Nothing
MsgBox "Mail gönderildi"
End Sub

çok teşekkür ederim tam istediğim gibi oldu
emeğinize sağlık

 

[turist]

Teşekkürler @aksoyolgun
Teşekkürler @ahmetalttun