vba da outlok ıle maıl gonderımınde hata

[hhd82]

Merhaba
Sayfam da asagıdakı kodlar ıle eposta gonderıyorum. Fakat eposta gitmeden outlok uygulamasını kapattıgı ıcın maıl gitmıyor. kodlar da outlok uygulamasını sımge durumunda kuculterek uygulamadan cıkış yapmamasını nasıl saglarım.

Private Sub CommandButton8_Click()

Dim OutApp As Object, Outmail As Object
Set OutApp = CreateObject("Outlook.Application")
Set Outmail = OutApp.CreateItem(0)
Outmail.BodyFormat = 2
With Outmail
.To = "aaaaaa@hotmail.com"
.CC = ""
.Subject = "DENEME"
dosya = Worksheets("veri").Range("G3").Value & ".txt"

.Attachments.Add (Environ("USERPROFILE") & "\Desktop\" & "\" & dosya)
'Not: Dosya yolunu yazdıktan sonra tırnak işaretlerini kaldırın
.Display
.Send 'Göndermek için .send den önceki ' tek tırnak işaretini kaldırın
End With
Set Outmail = Nothing: Set OutApp = Nothing

End Sub

 

[muhasebeciyiz]

Private Sub CommandButton8_Click()

    Dim OutApp As Object, OutMail As Object
    Dim ns As Object, exp As Object
    Dim dosya As String, fpath As String
    Dim so As Object

    On Error GoTo CleanFail
   
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    On Error GoTo 0
    If OutApp Is Nothing Then
        Set OutApp = CreateObject("Outlook.Application")
    End If

    Set ns = OutApp.GetNamespace("MAPI")  
    ns.Logon "", "", False, False
   
    If OutApp.Explorers.Count = 0 Then
        ' 6 = olFolderInbox, 0 = olFolderDisplayNormal
        Set exp = OutApp.Explorers.Add(ns.GetDefaultFolder(6), 0)
        exp.Display
        exp.WindowState = 1  ' 1 = olMinimized
    Else
        OutApp.ActiveExplorer.WindowState = 1  
    End If
   
    Set OutMail = OutApp.CreateItem(0)

    dosya = Worksheets("veri").Range("G3").Value & ".txt"
    fpath = Environ$("USERPROFILE") & "\Desktop\" & dosya  

    With OutMail
        .To = "aaaaaa@hotmail.com"
        .CC = ""
        .Subject = "DENEME"
        .BodyFormat = 2   ' 2 = olFormatHTML
        .HTMLBody = "Merhaba,<br><br>Deneme e-postası.<br><br>Saygılar."
        If Len(Dir$(fpath)) > 0 Then
            .Attachments.Add fpath
        Else
            MsgBox "Ek dosya bulunamadı: " & fpath, vbExclamation
        End If
        '.Display        
        .Send            
    End With
   
    On Error Resume Next
    For Each so In ns.SyncObjects
        so.Start
    Next
    On Error GoTo 0

CleanExit:
    Set OutMail = Nothing
    Set exp = Nothing
    Set ns = Nothing
    Set OutApp = Nothing
    Exit Sub

CleanFail:
    MsgBox "E-posta gönderilirken hata oluştu: " & Err.Description, vbExclamation
    Resume CleanExit
End Sub

Bu haliyle Outlook arka planda açık kalır ve e-postanız çıkış yapmadan gönderilir.

 

[hhd82]

Çok tesekurler.