Belirli Aralığı Mail Ekinde Excel Olarak Göndermek

B

bydogannn67

Altın Üye
Katılım
6 Ocak 2016
Mesajlar
226
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
03-09-2029
Merhaba aşağıdaki kod ile excel sayfasını mail olarak gönderebiliyoruz

Fakat istediğim excel sayfasının hepsini değilde A1:H25 aralığını excel olarak mail ekinde gönderebilmek

Yardımcı olabilirseniz çok sevinirim

Kod: 
Sub Mail_At()
On Error Resume Next
Application.ScreenUpdating = False
Sheets("yetki").Select
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb As Workbook
Dim Destwb As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim OutApp As Object
Dim OutMail As Object

'Aşağıdaki eklendi
Dim strBody As String, strSig As String
'

On Error Resume Next
Set OutApp = GetObject(, "Outlook.Application")
If OutApp Is Nothing Then
Application.ActivateMicrosoftApp (xlMicrosoftMail)
End If

With Application
.ScreenUpdating = True
.EnableEvents = True
End With

Set Sourcewb = ActiveWorkbook
ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With
TempFilePath = Environ$("temp") & "\"
TempFileName = "Şifre Hatırlatma"
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = "deneme@hotmail.com"
.CC = ""
.bcc = ""
.Subject = "Şifre Hatırlatma"
'.Body = "Saygılarımla" 'BUNU İPTAL ETTİM
.Attachments.Add Destwb.FullName
.Display

 .Recipients.ResolveAll
 
'Default İmza Eklendi
 strSig = .Htmlbody
 
'BODY YERİNE strBody kullan
 strBody = "<font face=Tahoma size=3> Saygılarımla </calibri> <p>" & _
 "<font color=green> Saygılarımla " & _
 "please visit: <mailto=deneme.gov.tr</a></font>"
 
 .Htmlbody = strBody & strSig


End With
On Error GoTo 0
.Close SaveChanges:=True
End With
Kill TempFilePath & TempFileName & FileExtStr
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
Sheets("ANA SAYFA").Select
MsgBox "Mail gönderme işlemi tamamlanmıştır.", 64, "Bilgi_Mesajı"
End Sub
 
M

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
724
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Kod: 
Sub Mail_Range_As_Excel()
    On Error Resume Next
    Application.ScreenUpdating = False
    
    Dim FileExtStr As String
    Dim FileFormatNum As Long
    Dim Sourcewb As Workbook
    Dim Destwb As Workbook
    Dim TempFilePath As String
    Dim TempFileName As String
    Dim OutApp As Object
    Dim OutMail As Object
    
    'Aşağıdaki eklendi
    Dim strBody As String, strSig As String
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then
        Application.ActivateMicrosoftApp (xlMicrosoftMail)
    End If
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Set Sourcewb = ActiveWorkbook
    'Yalnızca belirtilen aralığı kopyala
    Sheets("yetki").Range("A1:H25").Copy
    Set Destwb = Workbooks.Add
    With Destwb.Sheets(1)
        .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
        .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
        .Name = "A1_H25_Range"
    End With
    
    With Destwb
        If Val(Application.Version) < 12 Then
            FileExtStr = ".xls": FileFormatNum = -4143
        Else
            Select Case Sourcewb.FileFormat
                Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
                Case 52:
                    If .HasVBProject Then
                        FileExtStr = ".xlsm": FileFormatNum = 52
                    Else
                        FileExtStr = ".xlsx": FileFormatNum = 51
                    End If
                Case 56: FileExtStr = ".xls": FileFormatNum = 56
                Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
            End Select
        End If
    End With
    
    TempFilePath = Environ$("temp") & "\"
    TempFileName = "Şifre Hatırlatma"
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With Destwb
        .SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
        On Error Resume Next
        With OutMail
            .To = "deneme@hotmail.com"
            .CC = ""
            .BCC = ""
            .Subject = "Şifre Hatırlatma"
            '.Body = "Saygılarımla" 'BUNU İPTAL ETTİM
            .Attachments.Add Destwb.FullName
            .Display
            
            .Recipients.ResolveAll
            
            'Default İmza Eklendi
            strSig = .HtmlBody
            
            'BODY YERİNE strBody kullan
            strBody = "<font face=Tahoma size=3> Saygılarımla </calibri> <p>" & _
                      "<font color=green> Saygılarımla " & _
                      "please visit: <mailto=deneme.gov.tr</a></font>"
            
            .HtmlBody = strBody & strSig
        End With
        On Error GoTo 0
        .Close SaveChanges:=True
    End With
    
    Kill TempFilePath & TempFileName & FileExtStr
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    MsgBox "Mail gönderme işlemi tamamlanmıştır.", 64, "Bilgi_Mesajı"
End Sub
Excel sayfasının yalnızca belirli bir aralığını (örneğin A1:H25) ek olarak göndermek için, yukardaki gibi bir yaklaşım uygulayabilirsiniz. Yani, önce sadece A1:H25 aralığını yeni bir çalışma kitabına kopyalarsınız, sonra bu kopyalanan çalışma kitabını mail olarak gönderebilirsiniz
 
Son düzenleme:
M

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
724
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Belirli bir aralığı doğrudan e-posta ekine eklemenin doğrudan bir yolu yoktur çünkü e-posta ekleri genellikle dosya olarak gönderilir. Ancak, VBA kodunu biraz değiştirerek belirli bir aralığı doğrudan HTML e-posta gövdesine dahil edebiliriz.
Aşağıda, belirttiğiniz aralığı (A1:H25) e-posta gövdesine dahil eden bir örnek bulunmaktadır:

Kod: 
Sub Mail_Range_As_HTML()
    On Error Resume Next
    Application.ScreenUpdating = False
    
    Dim Sourcewb As Workbook
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    
    'Aşağıdaki eklendi
    Dim strBody As String, strSig As String
    
    On Error Resume Next
    Set OutApp = GetObject(, "Outlook.Application")
    If OutApp Is Nothing Then
        Application.ActivateMicrosoftApp (xlMicrosoftMail)
    End If
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    Set Sourcewb = ActiveWorkbook
    Set rng = Sheets("yetki").Range("A1:H25")
    
    rng.Copy
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    
    With OutMail
        .To = "deneme@hotmail.com"
        .CC = ""
        .BCC = ""
        .Subject = "Şifre Hatırlatma"
        
        'HTML gövdesi oluşturma
        strBody = "<html><body>" & _
                  "<font face=Tahoma size=3> Saygılarımla </calibri> <p>" & _
                  RangetoHTML(rng) & _
                  "<p><font color=green> Saygılarımla " & _
                  "please visit: <mailto=deneme.gov.tr</a></font>" & _
                  "</body></html>"
        
        .HTMLBody = strBody
        .Display
        
        .Recipients.ResolveAll
    End With
    
    Set OutMail = Nothing
    Set OutApp = Nothing
    
    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
    
    MsgBox "Mail gönderme işlemi tamamlanmıştır.", 64, "Bilgi_Mesajı"
End Sub

Function RangetoHTML(rng As Range) As String
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    
    TempFile = Environ$("temp") & "\" & "Range.html"
    
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1, 1).PasteSpecial Paste:=xlPasteValues
        .Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
    End With
    
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    TempWB.Close savechanges:=False
    Kill TempFile
End Function
Bu kod, belirttiğiniz A1:H25 aralığını HTML formatına dönüştürerek e-posta gövdesine ekler. Böylece geçici bir dosya oluşturmadan doğrudan e-postanızda belirttiğiniz aralığı görebilirsiniz.
 
B

bydogannn67

Altın Üye
Katılım
6 Ocak 2016
Mesajlar
226
Excel Vers. ve Dili
2010 türkçe
Altın Üyelik Bitiş Tarihi
03-09-2029
Merhaba, desteğiniz için teşekkur ederim,

istediğim hem mail ekinde excel olarak sayfa2deki verileri paylaşmak aynı zamanda mail içeriğindede sayfa1 deki verileri eklemek,

uğrastım bir sonuca ulaşamadım yardımcı olabilirmisiniz
 

Ekli dosyalar

M

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
724
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
İlk olarak, e-posta ekine Sayfa2'yi eklemeniz gerekiyor. Bunun için bir .xlsx dosyası oluşturup bunu ekleyebiliriz. Ardından, Sayfa1'deki verileri e-posta içeriğine ekleyebiliriz.Makromuz Sayfa2'deki verileri geçici bir .xlsx dosyasına kaydeder ve bu dosyayı e-posta ekine ekler. Aynı zamanda, Sayfa1'deki verileri HTML formatında e-posta içeriğine ekler.

Deneyiniz
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Üst