makro ile mail gönderme yardım..

[erkandeveci]

merhabalar
İlk gönderdiğimde mail in outbox ında sent kısmı none geldiğinden gönderim yapmıyor sonrasında tekrar gönder dediğimde mail atıyor
Bu mkaroya bir şey daha ekleyebilrmiyiz mail gönderirken Mail info daki C sütununa CC ye D sütununa da BCC yi ekleme bunlar birden fazla kişiler de olabilir ve ayrı bir sheet açarak subject ve body line a ekliceğimiz standart yazının olmasını da ekleyebilirimiyim
şimdiden çok teşekkür edebilirmiyiz
makro kodu :

Option Explicit

Sub Send_Row_Or_Rows_Attachment_1()
'Working in 97-2010
Dim rng As Range
Dim Ash As Worksheet
Dim Cws As Worksheet
Dim Rcount As Long
Dim Rnum As Long
Dim FilterRange As Range
Dim FieldNum As Integer
Dim mailAddress As String
Dim NewWB As Workbook
Dim TempFilePath As String
Dim TempFileName As String
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim I As Long

On Error GoTo cleanup

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


Set Ash = ActiveSheet


Set FilterRange = Ash.Range("A1:N" & Ash.Rows.Count)
FieldNum = 1 'Filter column = A because the filter range start in column A


Set Cws = Worksheets.Add
FilterRange.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Cws.Range("A1"), _
CriteriaRange:="", Unique:=True

'Count of the unique values + the header cell
Rcount = Application.WorksheetFunction.CountA(Cws.Columns(1))

'If there are unique values start the loop
If Rcount >= 2 Then
For Rnum = 2 To Rcount


mailAddress = ""
On Error Resume Next
mailAddress = Application.WorksheetFunction. _
VLookup(Cws.Cells(Rnum, 1).Value, _
Worksheets("Mailinfo").Range("A1:B" & _
Worksheets("Mailinfo").Rows.Count), 2, False)
On Error GoTo 0

If mailAddress <> "" Then

'Filter the FilterRange on the FieldNum column
FilterRange.AutoFilter Field:=FieldNum, _
Criteria1:=Cws.Cells(Rnum, 1).Value

'Copy the visible data in a new workbook
With Ash.AutoFilter.Range
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeVisible)
On Error GoTo 0
End With

Set NewWB = Workbooks.Add(xlWBATWorksheet)

rng.Copy
With NewWB.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

'Create a file name
TempFilePath = Environ$("temp") & "\"
TempFileName = "Your data of " & Ash.Parent.Name _
& " " & Format(Now, "dd-mmm-yy h-mm-ss")

If Val(Application.Version) < 12 Then
'You use Excel 2000-2003
FileExtStr = ".xls": FileFormatNum = -4143
Else
'You use Excel 2007-2010
FileExtStr = ".xlsx": FileFormatNum = 51
End If

'Save, Mail, Close and Delete the file
With NewWB
.SaveAs TempFilePath & TempFileName _
& FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
For I = 1 To 3
.SendMail mailAddress, _
"This is the Subject line"
If Err.Number = 0 Then Exit For
Next I
On Error GoTo 0
.Close SaveChanges:=False
End With

Kill TempFilePath & TempFileName & FileExtStr
End If

'Close AutoFilter
Ash.AutoFilterMode = False

Next Rnum
End If

cleanup:
Application.DisplayAlerts = False
Cws.Delete
Application.DisplayAlerts = True

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

 

[Korhan Ayhan]

Merhaba,

Neden önceki açtığınız başlıkta sorunuza devam etmiyor sunuz? Önceki açtığınız başlıkla bu konu farklımı?

 

[erkandeveci]

farklı değil aslında ama araştırdım bulamadığım için bu şekilde konu başlığı açyım yani makro yazmayı iyi iblmediğim için bulduğum makro ya istediğimm şekiilde denedim ama başaramadım...
sadce farklı başlıkta yardım istemiştim...

 

[Korhan Ayhan]

Peki siz eski bir üyemizsiniz. Bu şekilde bir davranış forum kurallarına uygun mu?

 

[kerimsarikaya]

Mail e dosya eklenimini nasil yapacagiz

Mail gonderirken makronun yazili oldugu dosyayi da eklemek istiyorum.elimde bunun icin bir mail var fakat .Attachments.Add"" sonra otaya ne yazmam gerekiyor bilmiyorum.yardima ihtiyacim var
Tesekurler