Makro ile mail gönderme

olmayan · 8 Ekim 2015

Merhaba, ekli makro ile müşterilere toplu mail gönderiyorduk, ama office 2010 dan sonra çalışmamaya başladı. sheet1 deki şube kodlarına göre ayırım yapıp şubeler sheettin deki şube kodlarına göre ayrı ayrı mail gönderiyordu. belki çok kolay bişi ama bir türlü çözemedim. yardımlarınızı rica ederim. teşekkürler kodları aşıya ekledim.

olmayan · 8 Ekim 2015

outlook için aşağıdaki kod yazılmış;

Public Function SendMailSafe(strTo As String, _
strCC As String, _
strBCC As String, _
strSubject As String, _
strMessageBody As String, _
Optional strAttachments As String) As Boolean

On Error GoTo ErrorHandler:

Dim MAPISession As Outlook.NameSpace
Dim MAPIFolder As Outlook.MAPIFolder
Dim MAPIMailItem As Outlook.MailItem
Dim oRecipient As Outlook.Recipient

Dim TempArray() As String
Dim varArrayItem As Variant
Dim strEmailAddress As String
Dim strAttachmentPath As String

Dim blnSuccessful As Boolean

'Get the MAPI NameSpace object
Set MAPISession = Application.Session

If Not MAPISession Is Nothing Then

'Logon to the MAPI session
MAPISession.Logon , , True, False

'Create a pointer to the Outbox folder
Set MAPIFolder = MAPISession.GetDefaultFolder(olFolderOutbox)
If Not MAPIFolder Is Nothing Then

'Create a new mail item in the "Outbox" folder
Set MAPIMailItem = MAPIFolder.Items.Add(olMailItem)
If Not MAPIMailItem Is Nothing Then

With MAPIMailItem

'Create the recipients TO
TempArray = Split(strTo, ";")
For Each varArrayItem In TempArray

strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olTo
Set oRecipient = Nothing
End If

Next varArrayItem

'Create the recipients CC
TempArray = Split(strCC, ";")
For Each varArrayItem In TempArray

strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olCC
Set oRecipient = Nothing
End If

Next varArrayItem

'Create the recipients BCC
TempArray = Split(strBCC, ";")
For Each varArrayItem In TempArray

strEmailAddress = Trim(varArrayItem)
If Len(strEmailAddress) > 0 Then
Set oRecipient = .Recipients.Add(strEmailAddress)
oRecipient.Type = olBCC
Set oRecipient = Nothing
End If

Next varArrayItem

'Set the message SUBJECT
.Subject = strSubject

'Set the message BODY (HTML or plain text)
If StrComp(Left(strMessageBody, 6), "<HTML>", vbTextCompare) = 0 Then
.HTMLBody = strMessageBody
Else
.Body = strMessageBody
End If

'Add any specified attachments
TempArray = Split(strAttachments, ";")
For Each varArrayItem In TempArray

strAttachmentPath = Trim(varArrayItem)
If Len(strAttachmentPath) > 0 Then
.Attachments.Add strAttachmentPath
End If

Next varArrayItem

.Send 'No return value since the message will remain in the outbox if it fails to send

Set MAPIMailItem = Nothing

End With

End If

Set MAPIFolder = Nothing

End If

MAPISession.Logoff

End If

'If we got to here, then we shall assume everything went ok.
blnSuccessful = True

ExitRoutine:
Set MAPISession = Nothing
SendMailSafe = blnSuccessful

Exit Function

ErrorHandler:
MsgBox "An error has occured in the user defined Outlook VBA function FnSendMailSafe()" & vbCrLf & vbCrLf & _
"Error Number: " & CStr(Err.Number) & vbCrLf & _
"Error Description: " & Err.Description, vbApplicationModal + vbCritical
Resume ExitRoutine

End Function

olmayan · 8 Ekim 2015

excell için ;
Sub SubeyeGoreBol()
'
' SubeyeGoreBol Macro
' Macro recorded 11.12.2008 by U006022
'

'
Dim subeKod As String
Dim thisSheet As Worksheet
Dim tmpBook As Workbook
Dim tmpSheet As Worksheet
Dim sourceRow As Integer, destRow As Integer
Dim ol As New Outlook.Application

Dim objNameSpace As Object
Dim objExplorer As Object

Set objNameSpace = ol.GetNamespace("MAPI")
Set objExplorer = ol.Explorers.Add(objNameSpace.Folders(1), 0)

objExplorer.CommandBars.FindControl(, 1695).Execute

objExplorer.Close

Set objNameSpace = Nothing
Set objExplorer = Nothing

Set thisSheet = ActiveSheet

thisSheet.Range("A2:M65000").Sort Key1:=Range("B3"), _
Order1:=xlAscending, _
Header:=xlYes, _
OrderCustom:=1, _
MatchCase:=False, _
Orientation:=xlTopToBottom, _
DataOption1:=xlSortTextAsNumbers

subeKod = thisSheet.Range("B3").Value

sourceRow = 3
destRow = 3

Do While Trim(subeKod) <> ""
Set tmpBook = Workbooks.Add
Set tmpSheet = tmpBook.Sheets(1)
thisSheet.Range("A2:M2").Copy tmpSheet.Range("A2:M2")

Do While thisSheet.Range("B" & sourceRow).Value = subeKod
thisSheet.Range("A" & sourceRow & ":M" & sourceRow).Copy tmpSheet.Range("A" & destRow & ":M" & destRow)
sourceRow = sourceRow + 1
destRow = destRow + 1
Loop

tmpSheet.Columns("A:M").EntireColumn.AutoFit

Dim path As String
path = ThisWorkbook.path & "\" & subeKod & ".xls"

On Error Resume Next
Kill path

On Error GoTo 0
tmpBook.SaveAs Filename:=ThisWorkbook.path & "\" & subeKod & ".xls", ConflictResolution:=xlLocalSessionChanges, AddToMru:=False
tmpBook.Close
Set tmpSheet = Nothing
Set tmpBook = Nothing

Dim toAddress As String, cc As String, subject As String, body As String

toAddress = FindTo(subeKod)
subject = thisSheet.Range("M1").Value
body = thisSheet.Range("N1").Value
cc = thisSheet.Range("O1").Value & ";" & FindCC(subeKod)

If toAddress = "" Then
MsgBox subeKod & " kodlu şube için 'To' bulunamadı.", vbExclamation, "Uyarı"
End If

ol.SendMailSafe toAddress, cc, "", subject, body, path

subeKod = thisSheet.Range("B" & sourceRow).Value
destRow = 3
Loop

Set ol = Nothing

End Sub

Function FindTo(ByVal subeKod As String) As String

FindTo = Find(subeKod, "C")

End Function

Function FindCC(ByVal subeKod As String) As String

FindCC = Find(subeKod, "D")

End Function

Function Find(ByVal subeKod As String, ByVal column As String) As String

Dim subeSheet As Worksheet
Set subeSheet = ThisWorkbook.Sheets("Subeler")

Dim tmpKod As String, toName As String
Dim i As Integer
tmpKod = subeSheet.Range("A2").Value
toName = subeSheet.Range(column & "2").Value
i = 2

Do While tmpKod <> "" And tmpKod <> subeKod
i = i + 1
tmpKod = subeSheet.Range("A" & i).Value
toName = subeSheet.Range(column & i).Value
Loop

Find = toName

End Function

Makro ile mail gönderme

olmayan

Ekli dosyalar

olmayan

olmayan