PDA

View Full Version : Need Help In VBA Script for sending Mail though OutLook with Excel



rushshukla84
11-11-2008, 03:23 AM
:hi: Can anybody :help in VB Code i used it for sending multiple mails in which i get to Email ids from one cell and then i check yes in another cell and then it goes to outlook outbox

But now i need different scenario which is :banghead: for me

I need to send in following way

Cellone : Email id of To (To whom i am sending email)
CellTwo : Email ID of from ( My ID)
CellThree : Password of From ID (For web authentication in out look )
CellFour : Yes

so i :dunno how to do it My Previous code i is as below which is working perfectly

-------------------------------------------------------
Sub TestFile()
Dim OutApp As Object
Dim OutMail As Object
Dim cell As Range

Dim strbody As String
For Each cell In ThisWorkbook.Sheets("Sheet1").Range("E1:E20")
strbody = strbody & cell.Value & vbNewLine
Next
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon

On Error GoTo cleanup
For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And LCase(cell.Offset(0, 1).Value) = "yes" Then
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = cell.Value
.Subject = ""
.HTMLBody = ""
.Send
End With
On Error GoTo 0

Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True


End Sub

-----------------------------------------------


Hey anybody can help me to come out of this program

Bob Phillips
11-11-2008, 05:57 AM
Sub TestFile()
Dim OutApp As Object
Dim OutMail As Object
Dim oNameSpace As Object
Dim cell As Range
Dim strbody As String

For Each cell In ThisWorkbook.Sheets("Sheet1").Range("E1:E20")
strbody = strbody & cell.Value & vbNewLine
Next
Application.ScreenUpdating = False
Set OutApp = CreateObject("Outlook.Application")
Set oNameSpace = oOutlook.GetNameSpace("MAPI")
oNameSpace.Logon "myProfile", "myPassword", True

On Error GoTo cleanup

For Each cell In Sheets("Sheet1").Columns("B").Cells.SpecialCells(xlCellTypeConstants)
If cell.Value Like "?*@?*.?*" And _
LCase(cell.Offset(0, 1).Value) = "yes" Then

Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.to = cell.Value
.Subject = ""
.HTMLBody = ""
.Send
End With
On Error GoTo 0

Set OutMail = Nothing
End If
Next cell

cleanup:
Set OutApp = Nothing
Application.ScreenUpdating = True

End Sub