- Katılım
- 26 Mayıs 2013
- Mesajlar
- 17
- Excel Vers. ve Dili
- 2010
Arkadaşlar Merhaba,
Ekli excel ile N sutünundaki kritere göre MAİL sayfasındaki tanımlı adreslere mail gönderimi yapıyorum.Ancak iki sorunum mevcut olup beni yönlendirirseniz çok sevinirim.
1.Makro içinde mail gönderimi yapan kodu KodTalep adı altındaki başka bir fonksiyon içinde topladığımda gönderim yapamıyorum.
2.Mail gövdesindeki yazıları nasıl renklendirip kalın yapabilir?
Yapacağınız yardımlar için şimdiden çok teşekkür ederim.
*****************************************************
http://s4.dosya.tc/server/dBWx3X/Deneme2.rar.html
Ekli excel ile N sutünundaki kritere göre MAİL sayfasındaki tanımlı adreslere mail gönderimi yapıyorum.Ancak iki sorunum mevcut olup beni yönlendirirseniz çok sevinirim.
1.Makro içinde mail gönderimi yapan kodu KodTalep adı altındaki başka bir fonksiyon içinde topladığımda gönderim yapamıyorum.
2.Mail gövdesindeki yazıları nasıl renklendirip kalın yapabilir?
Yapacağınız yardımlar için şimdiden çok teşekkür ederim.
*****************************************************
Kod:
Private Sub CommandButton1_Click()
Dim S1 As Worksheet
Dim syf As Worksheet
For Each syf In Worksheets
On Error Resume Next
If syf.FilterMode = False Then
Else
syf.ShowAllData
End If
Next syf
Set Sh = ActiveSheet
Sh.Range("F2:N2").AutoFilter Field:=9, Criteria1:="OK"
Set S1 = Sheets("MAIL")
S1.Columns("A:A").ClearContents
Columns("J:J").Copy
S1.Columns(1).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Application.CutCopyMode = False
S1.Range("$A$1:$A$65536").RemoveDuplicates Columns:=1, Header:=xlNo
Range("A1").Select
Call Mail
End Sub
*****************************************************
Sub Mail()
' Dim rng As Range
' Dim OutApp As Object
' Dim OutMail As Object
Dim Sh As Worksheet
Set Sh = ActiveSheet
Set S1 = Sheets("MAIL")
For i = 3 To [MAIL!A65536].End(3).Row
Sh.Range("F2:N2").AutoFilter Field:=5, Criteria1:=S1.Cells(i, "A").Text
Call KodTalep
' With Application
' .EnableEvents = False
' .ScreenUpdating = False
' End With
' Set rng = Nothing
' Set rng = ActiveSheet.UsedRange
' Set OutApp = CreateObject("Outlook.Application")
' Set OutMail = OutApp.CreateItem(0)
' strbody = "BU YAZILAR NASIL KALIN VE " & vbNewLine & vbNewLine & _
' "RENKLİ OLABİLİR." & vbNewLine & _
' "" & vbNewLine & _
' "" & vbNewLine & _
' ""
' On Error Resume Next
' With OutMail
' .To = S1.Cells(i, "B")
' .CC = ""
' .BCC = ""
' .Subject = "MAİLİN KONUSUNU BU KISMA YAZABİLİRSİNİZ "
' .HTMLBody = strbody & RangetoHTML(rng)
' .Send
' End With
' On Error GoTo 0
' With Application
' .EnableEvents = True
' .ScreenUpdating = True
' End With
' Set OutMail = Nothing
' Set OutApp = Nothing
Next
End Sub
*********************************************
Sub KodTalep()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim Sh As Worksheet
Set Sh = ActiveSheet
Set S1 = Sheets("MAIL")
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "Merhaba, " & vbNewLine & vbNewLine & _
"Aşağıdaki müşteri DBS kapsamında sizinle DBS kapsamında çalışmak istemektedir" & vbNewLine & _
"Bu kapsamda kod bilgisi iletildiği taktirde müşteri sisteme tanımlanacaktır." & vbNewLine & _
"Saygılarımla," & vbNewLine & _
""
On Error Resume Next
With OutMail
.To = S1.Cells(i, "B")
.CC = ""
.BCC = ""
.Subject = "MAİLİN KONUSUNU BU KISMA YAZABİLİRSİNİZ "
.HTMLBody = strbody & RangetoHTML(rng)
.Send
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)
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"
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
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
RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
"align=left x:publishsource=")
TempWB.Close SaveChanges:=False
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Functionhttp://s4.dosya.tc/server/dBWx3X/Deneme2.rar.html
Son düzenleme:
