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