Seçili Hücre Aralığını Boş Kitap İçinde Mail Gönderme

Seçili hücre aralığını boş bir ktap içinde mail göndermek isterseniz, aşağıdaki kodları [b]modüle[/b] yapıştırıp deneyebilirsiniz...

[img] [/img]
[img] [/img]

■ [b]Bu kodları kullanabilirsiniz;[/b]

Sub Secilen_Araligi_Mail_At()

'Office 2000-2010 sürümlerinde çalışır
    Dim Source As Range, Dest As Workbook, wb As Workbook,TempFilePath As String,TempFileName As String
    Dim FileExtStr As String, FileFormatNum As Long, I As Long
    Set Source = Nothing
    On Error Resume Next
    Set Source = Selection.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    If Source Is Nothing Then
        MsgBox "Gizli ve korumalı hücreleri düzeltin ve tekrar deneyin.", vbOKOnly
        Exit Sub
    End If
    If ActiveWindow.SelectedSheets.Count > 1 Or _
       Selection.Cells.Count = 1 Or _
       Selection.Areas.Count > 1 Then
               MsgBox "                   Bir hata oluştu:" & vbNewLine & vbNewLine & _
               "Seçim yapmadınız, hücre aralığını seçin.", vbOKOnly, "Www.ExcelVBA.Net"
        Exit Sub
    End If
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set wb = ActiveWorkbook
    Set Dest = Workbooks.Add(xlWBATWorksheet)
    Source.Copy
    With Dest.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial Paste:=xlPasteValues
        .Cells(1).PasteSpecial Paste:=xlPasteFormats
        .Cells(1).Select
        Application.CutCopyMode = False
    End With
    TempFilePath = Environ$("temp") & "\"
    TempFileName = wb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")
    If Val(Application.Version) < 12 Then
        'Excel 2000-2003 için
        FileExtStr = ".xls": FileFormatNum = -4143
    Else
       'Excel 2007-2010 için
        FileExtStr = ".xlsx": FileFormatNum = 51
    End If
    With Dest
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        For I = 1 To 3
            .SendMail "", _
                      "Buraya Konuyu Yazın"
            If Err.Number = 0 Then Exit For
        Next I
        On Error GoTo 0
        .Close SaveChanges:=False
    End With
    Kill TempFilePath & TempFileName & FileExtStr
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Hoşça kalın !