Excel, send emails, vba, question

[forums1167]

Hello, I need help with VBA code. I am sending ticket resolved emails thru excel starting in the third row. I would like to loop this so if we have say 6 resolved tickets, it will loop and display each email in Outlook. So far, this code is still only working for one email, it will not display 6 emails for 6 resolved tickets. I have tried a while loop and for loop, and this does not work. Any help and advice is much appreciated, thank you.

Sub TicketResolvedLoop()

Dim OutApp As Object
Dim Outmail As Object
Dim strBody As String
Dim SigString As String
Dim Signature As String
Dim i As Integer
Set OutApp = CreateObject("Outlook.Application")
OutApp.session.logon
Set Outmail = OutApp.CreateItem(0)

i = 3
While Cells(i, 1).Value <> ""

strBody = "Hello," & vbCrLf & vbCrLf & "The ticket that was opened for this for this issue has been resolved." & vbCrLf & vbCrLf _
& Cells(i, 1) & " " & Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4) & " " & Cells(i, 5) & vbCrLf & vbCrLf _
& "If you do not believe that this issue is resolved, please Reply to All within 3 business days so that we may re-open the ticket. If the issue is resolved then no reply is needed." & _
" We appreciate the opportunity to serve you and have a great day!" & vbCrLf & vbCrLf _
& "Thanks,"
'hello
SigString = Environ("appdata") & _
"\Microsoft\Signatures\main.txt"
If Dir(SigString) <> "" Then
Signature = GetBoiler(SigString)
Else
Signature = ""
End If

On Error Resume Next
With Outmail
.To = Cells(i, 3) & "; myself" 'change "test@test.com" into "yourownmailadres@mail.com" to make the macro really work
.CC = ""
.BCC = ""
.Subject = "Ticket Resolved"
.Body = strBody & vbNewLine & vbNewLine & Signature
.Display
End With
On Error GoTo 0
Set Outmail = Nothing
Set OutApp = Nothing
i = i + 1
Wend
End Sub


Also, this uses function inside the module of:

Function GetBoiler(ByVal sFile As String) As String
'Dick Kusleika
Dim fso As Object
Dim ts As Object
Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso.GetFile(sFile).OpenAsTextStream(1, -2)
GetBoiler = ts.readall
ts.Close
End Function

[mdmackillop]

This is the code I use for multiple emails. It uses Redemption to avoid Outlook warnings. There are codes for Preview and Send
[VBA]
Option Explicit

'Requires reference to Redemption (http://www.dimastr.com/redemption/)

Sub Preview_Mail()

Dim OutApp As Object
Dim OutMail As Object
Dim t As Variant
Dim cel As Range
Dim txt As String
Dim sig As String
Dim Nm As String

Application.ScreenUpdating = False

Set OutApp = CreateObject("Redemption.RDOSession")
OutApp.Logon

On Error Resume Next

'Create text
For Each cel In Range("Bodytext")
If cel <> "" Then txt = txt & cel & vbCr & vbCr
Next

'Create Signature
For Each cel In Range("MySig")
sig = sig & cel & vbCr
Next

' Create "To" list
For Each t In Range("ToList")
If Len(t) > 1 Then
Set OutMail = OutApp.GetDefaultFolder(olFolderOutbox).Items.Add
With OutMail
.To = t
.Subject = Range("MySubject")
.Body = txt & vbCr & vbCr & sig
For Each cel In Range("MyAttach")
If cel <> "" Then .Attachments.Add cel.Text
Next
.Display
Exit For
End With
End If
Next
On Error GoTo 0

cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Application.ScreenUpdating = True

End Sub

Sub Send_Mail()
Dim OutApp As Object
Dim OutMail As Object
Dim t As Variant
Dim cel As Range
Dim txt As String
Dim sig As String
Dim Nm As String

Application.ScreenUpdating = False

Set OutApp = CreateObject("Redemption.RDOSession")
OutApp.Logon

On Error Resume Next

'Create text
For Each cel In Range("Bodytext")
If cel <> "" Then txt = txt & cel & vbCr & vbCr
Next

'Create Signature
For Each cel In Range("MySig")
sig = sig & cel & vbCr
Next

' Create "To" list
For Each t In Range("ToList")
If Len(t) > 1 Then
Set OutMail = OutApp.GetDefaultFolder(olFolderOutbox).Items.Add
With OutMail
.To = t
.Subject = Range("MySubject")
.Body = txt & vbCr & vbCr & sig
For Each cel In Range("MyAttach")
If cel <> "" Then .Attachments.Add cel.Text
Next
.Send
End With
End If
Next
On Error GoTo 0

'Open outlook to send if required
Dim oOutlook As Object
Dim oNameSpace As Object
Dim oInbox As Object
Dim oBox As Object
Dim i As Long

Const ERR_APP_NOTRUNNING As Long = 429
On Error Resume Next
Dim w

' Handle Microsoft outlook
Set oOutlook = GetObject(, "Outlook.Application")
If Err = ERR_APP_NOTRUNNING Then
w = Err
Set oOutlook = CreateObject("Outlook.Application")
End If

Set oNameSpace = oOutlook.GetNamespace("MAPI")
Set oBox = oNameSpace.Folders("Outbox")

For i = 1 To oNameSpace.Folders.Count
Set oInbox = oNameSpace.Folders(i)
If Left(oInbox, 7) = "Mailbox" Then
Set oBox = oNameSpace.Folders(i).Folders("Outbox")
Exit For
End If
Next

Shell "Outlook.exe"
oBox.Select
Dim NewHour, NewMinute, NewSecond, WaitTime
NewHour = Hour(Now())
NewMinute = Minute(Now())
NewSecond = Second(Now()) + 5
WaitTime = TimeSerial(NewHour, NewMinute, NewSecond)
Application.Wait WaitTime



If oBox.Items.Count > 0 Then
SendKeys ("%cs")
Do Until oBox.Items.Count = 0
Application.StatusBar = "Sending " & oBox.Items.Count
NewHour = Hour(Now())
NewMinute = Minute(Now())
NewSecond = Second(Now()) + 1
WaitTime = TimeSerial(NewHour, NewMinute, NewSecond)
Application.Wait WaitTime
DoEvents
On Error GoTo Exits:
Loop
End If
Exits:
If Err <> 0 Then MsgBox "Error recorded", vbExclamation
If w > 0 Then oOutlook.Quit
Application.StatusBar = ""

cleanup:
Set OutMail = Nothing
Set OutApp = Nothing
Set oOutlook = Nothing
Set oOutlook = Nothing
Set oNameSpace = Nothing
Set oInbox = Nothing
Application.ScreenUpdating = True
MsgBox "Sent"

End Sub

Sub GetAttachments()

Dim fd As FileDialog
Dim vrtSelectedItem As Variant

Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
If .Show = -1 Then
For Each vrtSelectedItem In .SelectedItems
If Range("B24") = "" Then
Range("B24") = vrtSelectedItem
Else
Range("B31").End(xlUp).Offset(1) = vrtSelectedItem
End If
Next vrtSelectedItem
Else
End If
End With
Set fd = Nothing
End Sub

[/VBA]