Mail gönderirken .jpg imza srunu

[Hakan ERDOST]

Sub Belirlenen_Hucre_Araligini_Mesaj_Gövdesine_Gonder()
'Office 2000-2010 sürümlerinde çalışır
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set rng = Nothing
    On Error Resume Next
    Set rng = Sheets("Sayfa1").Range("A1:K42").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If rng Is Nothing Then
       MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display   'göndermek için .Send
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Bu kod ile A1-K42 aralığını mail gövdesine yazdırıyorum, ancak bu aralıkta bir de imzam var ancak bu imza aktarılmıyor. Kodda ne gibi değişiklik yapmam lazım?

 

[Emir Hüseyin Çoban]

. . .

İmzanızda resim mi... İmza alanının ekran görüntüsünü ekleyebilir misiniz.

. . .

 

[Hakan ERDOST]

. . .

İmzanızda resim mi... İmza alanının ekran görüntüsünü ekleyebilir misiniz.

. . .

Evet jpg dosyası. Klasik bir resmi yazı. Excel menüsünden çalışma sayfasına eklenmiş (tarama ile oluşturulmuş) bir jpg dosyası.

 

[Emir Hüseyin Çoban]

. . .

Jpeg dosyası bilgisayarınızda var ise oradan aldırabiliriz veya excel içerisinde dışarıya resim olarak çıkartabiliriz.
Örnek dosya üzerinde görmek gerekiyor.

. . .

 

[Hakan ERDOST]

. . .

Jpeg dosyası bilgisayarınızda var ise oradan aldırabiliriz veya excel içerisinde dışarıya resim olarak çıkartabiliriz.
Örnek dosya üzerinde görmek gerekiyor.

. . .

Dosya ekte.Bu şekliyle outlooka aktarıyorum, ancak imza aktarılmıyor.

 

[Emir Hüseyin Çoban]

. . .

Bu kod yapısı metin arasına resim eklemek için uygun değil.

Dilekçeyi metin gövdesi yerine, mail ekinde PDF olarak gönderebilirsiniz.


. . .

 

[Hakan ERDOST]

Teşekkürler.

 

[Emir Hüseyin Çoban]

. . .

Şu hale kadar getirebildim ancak tam olarak sağa yaslayamadım.

. . .

 

[Hakan ERDOST]

. . .

Şu hale kadar getirebildim ancak tam olarak sağa yaslayamadım.

. . .

Kodu alabilir miyim yada örnek dosyayı, Hüseyin bey.

 

[Emir Hüseyin Çoban]

. . .

Mesajlarınızda gereksiz alıntı yapmayın.

FunctionModule modülü için şu kodları kullanın.

Ekteki resim klasörünü C:\ sürücü altına yapıştırın.

Function RangetoHTML(rng As Range)

'Office 2000-2010 sürümlerinde çalışır
    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"
 
   ' Kopya aralığı ve geçmiş verileri yeni bir çalışma kitabı oluşturamazsınız
    rng.Copy
    Set TempWB = Workbooks.Add(1)
        'ActiveSheet.Paste
    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
 
    'Sayfayı htm dosyası olarak yayınla
    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
 
    'RangetoHTML içine htm dosyası olan tüm verileri oku
    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=")
 
 Sayfa3.Range("A1") = RangetoHTML
 
[COLOR="DarkRed"]'''
hyol = "C:\resim\imza.jpg"
r = "<IMG alt='' hspace=0 src='" & hyol & "' align=right border=0>"
h1 = Split(RangetoHTML, "<td class=xl")(1)
h2 = (Replace(h1, "></td>", "") * 1) - 100000
 RangetoHTML = Replace(RangetoHTML, "<td colspan=2 class=xl" & h2 & ">Müdür Müdür</td>", _
 r & "<BR><BR><BR><td colspan=2 class=xl" & h2 & ">Müdür Müdür</td>")
'''[/COLOR]


    'TempWB'yi kapat
    TempWB.Close savechanges:=False
 
    'htm dosyası olan bu fonksiyonu sil
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

. . .

 

[Hakan ERDOST]

hyol satırında hata verdi.

 

[Emir Hüseyin Çoban]

Modulde en ust satirda option ile baslayan satiri silin veya degisken tanimlamalarini yapin.

.

 

[Hakan ERDOST]

Deişken yukarıdaki gibi tanımladı dosya yoluna jpg atıldı ancak imza gelmiyor.

 

[Emir Hüseyin Çoban]

. . .

Yazdığınız değişkenleri ve option satırını silin.
Deneme yaparken kullandığım Sayfa3.Range("A1") = RangetoHTML satırınıda silin.

. . .