Mail gönderme Sorunu

[Mehmet Sait]

Deneyiniz.

Option Explicit

Sub Mail_Gonder()
    Dim K1 As Workbook, S1 As Worksheet, Yol As String, Dosya_Adi As String
    Dim Onay As Byte, Uygulama As Object, Yeni_Mail As Object
     
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    If Onay = vbNo Then
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        Exit Sub
    End If
     
    Set K1 = ThisWorkbook
    Set S1 = K1.Sheets(Range("D1").Text)
     
    If S1.Range("G2").Value = "" Then
        MsgBox "Lütfen tarih giriniz!", vbCritical
        S1.Range("G2").Select
        Exit Sub
    End If
     
    If S1.Range("G4").Value = "" Then
        MsgBox "Lütfen vardiya türünü giriniz!", vbCritical
        S1.Range("G4").Select
        Exit Sub
    End If
     
    If S1.Range("B93").Value = "" Then
        MsgBox "Lütfen imza giriniz!", vbCritical
        S1.Range("B93").Select
        Exit Sub
    End If
     
    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları"
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    Yol = CreateObject("WScript.Shell").SpecialFolders("Desktop") & _
          Application.PathSeparator & Year(Date) & " Üretim Vardiya Raporları" & Application.PathSeparator & Format(Date, "yyyy mm")
    If Dir(Yol, vbDirectory) = "" Then MkDir (Yol)

    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
 
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
 
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)
 
    Dosya_Adi = S1.Range("G2").Value & " " & S1.Range("G4").Value & ".xlsx"

    S1.Copy
    On Error Resume Next
    ActiveSheet.DrawingObjects.Delete
    On Error GoTo 0
    Application.DisplayAlerts = False
    ActiveWorkbook.SaveAs Yol & Application.PathSeparator & Dosya_Adi, 51
    Application.DisplayAlerts = True
   
    With Yeni_Mail
        .Display
        .To = S1.Range("V2").Value
        .CC = S1.Range("V3").Value
        .BCC = S1.Range("V4").Value
        .Subject = S1.Range("G2").Value & " " & S1.Range("G4").Value
        .HTMLBody = S1.Range("V4").Value & "<br>" & .HTMLBody
        .Attachments.Add Yol & Application.PathSeparator & Dosya_Adi
        .BodyFormat = 2
        .Save
        .Send
    End With
 
    'S1.PageSetup.PrintArea = "$B$2:$R$96"
    'S1.PrintOut Copies:=1, Collate:=True, IgnorePrintAreas:=False
 
    MsgBox "E-mail gönderilmiştir.", vbInformation
 
    Set K1 = Nothing
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub

Teşekkür ederim Hocam