Mail gönderirken imza bölümü

[1903emre34@gmail.com]

Merhaba,

Aşağıdaki kod aracılığıyla, excel üzerinden direkt olarak mail gönderiyorum ama resimdeki imza kısmı mailde görünmesi için aşağıdaki kodlarda nasıl değişiklik yapabiliriz, forumda baktım uygulama yapamadım.

Dim alan As Range
Dim kime, bilgi, icerik As String

Private Sub ComboBox1_Change()

End Sub

Private Sub CommandButton1_Click()
   kime = ""

   For j = 0 To ListBox2.ListCount - 1
     If ListBox2.Selected(j) Then
        kime = kime & ListBox2.List(j) & ";"
     End If
   Next j
   bilgi = ""
   For j = 0 To ListBox3.ListCount - 1
     If ListBox3.Selected(j) Then
        bilgi = bilgi & ListBox3.List(j) & ";"
     End If
   Next j
   
   Call mail_gonder
End Sub

Private Sub UserForm_Initialize()

'LİSTBOX 1
ListBox1.ColumnCount = 6
ListBox1.ColumnWidths = "60,150,75,60,60,60"
ListBox1.RowSource = "İMZALAR!A1:F" & Sheets("İMZALAR").[a65536].End(xlUp).Row

'LİSTBOX 2
ListBox2.ColumnCount = 1
ListBox2.ColumnWidths = "150"
ListBox2.RowSource = "MAİLLER!A1:A" & Sheets("MAİLLER").[a65536].End(xlUp).Row

'LİSTBOX 3
ListBox3.ColumnCount = 1
ListBox3.ColumnWidths = "150"
ListBox3.RowSource = "MAİLLER!A1:A" & Sheets("MAİLLER").[a65536].End(xlUp).Row

 Application.ScreenUpdating = False
 Range("A:F").Select
    ActiveWorkbook.Worksheets("İMZALAR").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("İMZALAR").Sort.SortFields.Add Key:=Range("A1"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("İMZALAR").Sort
        .SetRange Range("A:F")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    Range("A1").Select
Application.ScreenUpdating = True

End Sub

Sub mail_gonder()
    On Error GoTo mailatma
    Set evnout = CreateObject("Outlook.Application")
    Set evnmailitem = evnout.CreateItem(0)
    Set shimza = Sheets("İMZALAR")
    sonsatir = shimza.Cells(Rows.Count, "A").End(3).Row
    satir = 0 + ListBox1.ListIndex
    satir = satir + 1
    'Set alan = Range("A" & satir & ":F" & satir)
    baslik = Range("A" & satir).Value
    baslik = Replace(baslik, "{AY}", ComboBox1.Text)
    With evnmailitem
      .Subject = "Konu deneme"
      .To = kime
      .cc = bilgi
      '.Attachments.Add maildosya
      '.Htmlbody = "<br>" & RangetoHTML(alan) & .Htmlbody
      .Htmlbody = "<br>" & baslik & .Htmlbody
      
      .display
      '.send
    End With
mailatma:
    Set evnmailitem = Nothing
    Set evnout = 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, , 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

 

[1903emre34@gmail.com]

Arkadaşlar yardım edecek var mı?

 

[Emir Hüseyin Çoban]

.

Örnek dosya yükleyebilir misiniz.

.

 

[1903emre34@gmail.com]

Dosya ektedir, maili direkt gönderirken imza kısmını mailde görünmesi için kodlarda nasıl değişiklik yapabiliriz?

 

[Asri]

Mail gönder prosedürünü aşağıdaki şekilde değiştirip deneyiniz

Sub mail_gonder()
    On Error GoTo mailatma
    Dim imza As Range
    Set evnout = CreateObject("Outlook.Application")
    Set evnmailitem = evnout.CreateItem(0)
    Set shimza = Sheets("İMZALAR")
    sonsatir = shimza.Cells(Rows.Count, "A").End(3).Row
    satir = 0 + ListBox1.ListIndex
    satir = satir + 1
   [COLOR=Red] Set imza = Range("B23:B30")[/COLOR]
    baslik = Range("A" & satir).Value
    baslik = Replace(baslik, "{AY}", ComboBox1.Text)
    With evnmailitem
      .Subject = "Konu deneme"
      .To = kime
      .cc = bilgi
      [COLOR=red].BodyFormat = 2[/COLOR]
      .display
    [COLOR=red]  Set wrdEdit = evnout.ActiveInspector.WordEditor
      
      ActiveSheet.Shapes.Range(Array([COLOR=Blue]"Resimimza"[/COLOR])).Select
      Selection.Copy
      wrdEdit.Application.Selection.Paste[/COLOR]
      
      '.Attachments.Add maildosya
      '.Htmlbody = "<br>" & RangetoHTML(alan) & .Htmlbody
      .Htmlbody = "<br>" & baslik [COLOR=Red]& RangetoHTML(imza) & .Htmlbody[/COLOR]
      

      '.send
    End With
mailatma:
    Set evnmailitem = Nothing
    Set evnout = Nothing
   [COLOR=red] Set wrdEdit = Nothing[/COLOR]
End Sub

 

[1903emre34@gmail.com]

Üstad, teşekkürler, logo kısmı mailde görünmesi için değişiklik yapabilir misiniz?. Dosya ektedir.

 

[Asri]

Kod güncellendi.

Logo nun adını Resimimza olarak değiştirip deneyiniz.

 

[1903emre34@gmail.com]

İmza kısmı (logoyla birlikte) mailde göründü, yalnız listbox1'deki yazılar mailde görünmedi. Aşağıdaki kod aracılığıyla görünüyordu.

Sub mail_gonder()
    On Error GoTo mailatma
    Dim imza As Range
    Set evnout = CreateObject("Outlook.Application")
    Set evnmailitem = evnout.CreateItem(0)
    Set shimza = Sheets("İMZALAR")
    sonsatir = shimza.Cells(Rows.Count, "A").End(3).Row
    satir = 0 + ListBox1.ListIndex
    satir = satir + 1
    Set imza = Range("B23:B33")
    baslik = Range("A" & satir).Value
    baslik = Replace(baslik, "{AY}", ComboBox1.Text)
    With evnmailitem
      .Subject = "Beyannameler"
      .To = kime
      .cc = bilgi
      '.Attachments.Add maildosya
      '.Htmlbody = "<br>" & RangetoHTML(alan) & .Htmlbody
      .Htmlbody = "<br>" & baslik & .Htmlbody & RangetoHTML(imza)
      
      .display
      '.send
    End With
mailatma:
    Set evnmailitem = Nothing
    Set evnout = Nothing
End Sub

 

[Asri]

İmza kısmı (logoyla birlikte) mailde göründü, yalnız listbox1'deki yazılar mailde görünmedi. Aşağıdaki kod aracılığıyla görünüyordu.

İşleyişi çok fazla bilmiyorum ama A1 e "kj kljlk jlkdjhjk hk {AY} jhk hj" şeklinde veri giriğimde listbox da çıkıyor ve Ocak seçtiğimde de mailde görünüyor.

Bir problem göremedim.