Outlook mail gönderme kodunda yardım!!!

[djoguzz]

arkadaşlar herkese merhaba

Hocam aşağıdaki kod ile outlook üzerinden mail atmak istiyorum ama .Body = Sheets("ziraimailolustur").[A327] kısmı hata veriyor. mesaj içeriğini a3 ile d 27 arasını seçip almasını istiyorum ama hata veriyor kodda ne gibi bir hata var acaba ? Yardımcı olabilirseniz çok sevinirim teşekkürler şimdiden.

Sub mailhazirlaoutlook()
    Dim OutApp As Outlook.Application
    Dim NewMail As Outlook.MailItem
    Set OutApp = New Outlook.Application
    Set NewMail = CreateItem(olMailItem)
    With NewMail
    .To = [F1]
    .CC = ""
    .Subject = [A1] + [B1]
    .Body = Sheets("ziraimailolustur").[A3:D27]
    .Display
    End With
    Set OutApp = Nothing
    Set NewMail = Nothing
    End Sub

 

[hamitcan]

Bu şekilde deneyin.

Sub mailhazirlaoutlook()
    Dim OutApp As Outlook.Application
    Dim NewMail As Outlook.MailItem
    Set OutApp = New Outlook.Application
    Set NewMail = CreateItem(olMailItem)
  
  For i = 3 To 27
  For j = 1 To 4
    Rng = Rng & " " & Cells(i, j)
  Next
  Rng = Rng & Chr(10)
  Next
  
    With NewMail
    .To = [F1]
    .CC = ""
    .Subject = [A1] + [B1]
    .Body = Rng
    .Display
    End With
    Set OutApp = Nothing
    Set NewMail = Nothing
End Sub

 

[djoguzz]

Bu şekilde deneyin.

Sub mailhazirlaoutlook()
    Dim OutApp As Outlook.Application
    Dim NewMail As Outlook.MailItem
    Set OutApp = New Outlook.Application
    Set NewMail = CreateItem(olMailItem)
  
  For i = 3 To 27
  For j = 1 To 4
    Rng = Rng & " " & Cells(i, j)
  Next
  Rng = Rng & Chr(10)
  Next
  
    With NewMail
    .To = [F1]
    .CC = ""
    .Subject = [A1] + [B1]
    .Body = Rng
    .Display
    End With
    Set OutApp = Nothing
    Set NewMail = Nothing
End Sub

Hocam kodlar iyi güzelde manuel şekilde kopyala yapıştır yaptığımda kenarlıklar falanda oluyor ama bu şekilde kodlarla yaptığımda sadece yazılar oluyor kenarlıklarında olması gerekiyor.

 

[hamitcan]

Aşağıdaki linkte istediğiniz biçimde bir uygulama yapılmış, kendinize göre uyarlamaya çalışın.
http://www.rondebruin.nl/mail/folder3/mail4.htm

 

[djoguzz]

Aşağıdaki linkte istediğiniz biçimde bir uygulama yapılmış, kendinize göre uyarlamaya çalışın.
http://www.rondebruin.nl/mail/folder3/mail4.htm

Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "ron@debruin.nl"
        .CC = ""
        .BCC = ""
        .Subject = "This is the Subject line"
        .HTMLBody = RangetoHTML(rng)
        .Send   'or use .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    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
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

hocam bu kodları kendime göre uyarlamam ben o kadar bilgim yok malesef sizin verdiğiniz koda göre bu kodu nasıl uyarlayabiliriz ?

 

[djoguzz]

hocam hallettim şimdi biraz kurcaladım oldu teşekkür ederim tam istediğim gibi oldu şimdi Allah razı olsun başınızı ağrıttım kusuruma bakmayın.. İyi günler İyi çalışmalar....

 

[hamitcan]

Yaptığınız örneği ekleyin, herkes faydalansın.

 

[djoguzz]

Hocam şirket dosyası olduğu için paylaşamıyorum ama herkes faydalansın diye kodları ekleyip kodlar içinde açıklama yapayım..

Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    Set rng = Sheets("[COLOR="Red"]buraya sayfanızın ismi(sayfa1,sayfa2..)[/COLOR]").Range("[COLOR="Red"]A3:D27 (buraya hangi hücrelerin arasını mail olarak göndermek istiyorsanız hücreleri yazınız)[/COLOR]").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = [F1] [COLOR="Red"](mail göndermek istediğiniz adresi yazınız ben excelde f1 sütunundaki adrese göndermek istediğim için [F1] yazdım)[/COLOR]
        .CC = ""
        .BCC = ""
        .Subject = [A1] + [B1] (mailinizin konusun buraya yazınız ben exceldeki [A1] + [B1] hücrelerindeki verileri konu olarak yazmasını istediğim için böyle yaptım)
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    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
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Arkadaşlar ben şu an outlook 2010 kullanıyorum ve sorunsuz çalışıyor ama bu kodu kullanmak için vb düzenleyecisinde tools/references bölümünden Microsoft Outlook 14.0 Library seçili olmalıdır.

Kullandığım dosya şirket evrağı olduğu için burada paylaşım yapamıyorum sorunu olan arkadaşlar mesaj gönderirlerse yardımcı olmaya çalışırım..

 

[turgay25]

Sub Mail_Selection_Range_Outlook_Body()
' Don't forget to copy the function RangetoHTML in the module.
' Working in Office 2000-2010
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object

    Set rng = Nothing
    On Error Resume Next
    'Only the visible cells in the selection
    Set rng = Selection.SpecialCells(xlCellTypeVisible)
    'You can also use a range if you want
    Set rng = Sheets("").Range("").SpecialCells(xlCellTypeVisible)
    On Error GoTo 0

    If rng Is Nothing Then
        MsgBox "The selection is not a range or the sheet is protected" & _
               vbNewLine & "please correct and try again.", vbOKOnly
        Exit Sub
    End If

    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With

    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)

    On Error Resume Next
    With OutMail
        .To = "turgay.fidan@askalecimento.com;irfan.kocak@askalecimento.com"
        .CC = ""
        .BCC = ""
        .Subject = "deneme"
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With
    On Error GoTo 0

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

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2010
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
 
    TempFile = Environ$("temp") & "/" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
 
    'Copy the range and create a new workbook to past the data in
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
 
    'Publish the sheet to a htm file
    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
 
    'Read all data from the htm file into RangetoHTML
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.ReadAll
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
 
    'Close TempWB
    TempWB.Close savechanges:=False
 
    'Delete the htm file we used in this function
    Kill TempFile
 
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function

Bu şekilde mail adreslerini listeliyorum fakat gönderme işlemi gerçekleşmiyor.Ayrıca gönderi işlemi hangi adresten yapılıyor onuda belirtmek gerek.Konu hakkında yardımcı olursanız sevinirim.İyi çalışmalar.