AccessTr.neT

Merhaba.

Youtubeden bulup düzenledim.
İmza yerine Logo ekler.

Outlook htmlbody ile yapıldı.
Outlook ayarlarından gönderAl ile gönderilmeli.Yada ayarlardan otomatik seçilebilir bu ayar outlook kapatılırken.
Koda mailler yollanınca outllok açılması koduda ekledim.

Koda ilaveler yapılabilir.Orjinal videoyuda ekledim.

Umarım işe yarar üyelerin.


https://resim.accesstr.net/do.php?img=11038

Private Sub CommandButton1_Click()

Dim dosyaAdLogo As String

Dim outlookapp As Object

Dim outlookmailitem As Object

Dim ek_Ekle As Object

Dim yol As String

Dim son As Long

Dim ek As String

Dim x As Long



x = 2

If outlookAcikmi = True Then

    MsgBox "Outlook kapat ve tekrar calistir..", vbCritical, "Hata"

    Exit Sub

End If



With ThisWorkbook.Sheets("Sayfa1")

    Do While .Cells(x, 1).Value <> ""

        Set outlookapp = CreateObject("Outlook.Application")

        Set outlookmailitem = outlookapp.createitem(0)

        Set ek_Ekle = outlookmailitem.Attachments

        yol = ThisWorkbook.path & Application.PathSeparator

        dosyaAdLogo = "Bayrak.png"

        ek = yol & .Cells(x, 3).Value

        

        outlookmailitem.To = .Cells(x, 1).Value

        outlookmailitem.Subject = .Cells(x, 2).Value

        outlookmailitem.Attachments.Add yol & dosyaAdLogo, 0

        

        outlookmailitem.HTMLBody = _

            "Sayin  " & .Cells(x, 4).Value & "<br>" _

            & "<br> xxxxxxx<br>" _

            & "<br> yyyyyyy <br> " _

            & "<br> zzzzzzz<br><br><br>" _

            & " <br> <img src='" & dosyaAdLogo & "'" & "width='150' height='100'> "

                

        ek_Ekle.Add (ek)

        outlookmailitem.display

        Application.Wait (Now + TimeSerial(0, 0, 3))

    '        outlookmailitem.send

        Application.Wait (Now + TimeSerial(0, 0, 3))

        son = son + 1

        adres = vbNullString

        x = x + 1

        Set outlookapp = Nothing

        Set outlookmailitem = Nothing

    Loop

End With

OutlookAc

End Sub

Public Sub OutlookAc()

    Dim ws As Object

    Dim sPath As String

    Set ws = CreateObject("WScript.Shell")

    sPath = ws.RegRead("HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\App Paths\OUTLOOK.EXE\")

    Set ws = Nothing

    Call Shell(sPath)

End Sub

Function outlookAcikmi() As Boolean

    Dim objOutlook As Object

    outlookAcikmi = False

    On Error Resume Next

    Set objOutlook = GetObject(, "Outlook.Application")

    If Not objOutlook Is Nothing Then

        outlookAcikmi = True

    End If

    On Error GoTo 0

    Set objOutlook = Nothing

End Function

@Teşekkürler @feraz Hocam.

Rica ederim abey
Daha önceki yaptığımız resmi kopyalama yerine klasördeki bir resmi logo alıyor ve daha kullanışlı geldi.