Sub Readfromtext()
Dim fs
Dim a
Dim mSheet As Worksheet
Dim mRange As Range
Dim fAddress As String, bodyS As String, lAddress As String, mAddress As String
Dim firstName As String, secondName As String
Dim oApp
Dim mItem
Set mSheet = ThisWorkbook.Worksheets("Sheet1")
Set fs = CreateObject("Scripting.FileSystemObject")
On Error Resume Next
Set oApp = GetObject("", "Outlook.Application")
If Err.Number <> 9 Then
Set oApp = CreateObject("Outlook.Application")
End If
On Error GoTo 0
Set a = fs.OpenTextFile("C:\mail.txt")
Do While a.AtEndOfLine = False
mComputer = a.ReadLine
mAddress = Right(mComputer, Len(mComputer) - InStr(1, mComputer, ";"))
mComputer = Left(mComputer, InStr(1, mComputer, ";") - 1)
Set mRange = mSheet.UsedRange.Find(mComputer)
If Not mRange Is Nothing Then
fAddress = mRange.Address
firstName = mSheet.Cells(mRange.Row, 4).Text
Do
Set mItem = oApp.CreateItem(olMailItem)
bodyS = ""
With mItem
.To = mAddress
.Subject = mSheet.Cells(mRange.Row, 4).Text
bodyS = bodyS & "Hi " & Left(mAddress, InStr(1, mAddress, ".") - 1) & "," & vbCrLf
bodyS = bodyS & vbCrLf
bodyS = bodyS & "Some data in the body """ & mSheet.Cells(mRange.Row, 4).Text & """ some other data" & vbCrLf
bodyS = bodyS & vbCrLf
bodyS = bodyS & "Regards" & vbCrLf
bodyS = bodyS & "Sharath" & vbCrLf
.Body = bodyS & vbCrLf & Replace(mSheet.Cells(mRange.Row, 4).Hyperlinks(1).Address, " ", "%20")
.Save
End With
Set mRange = mSheet.UsedRange.FindNext(mRange)
If mRange Is Nothing Then
lAddress = ""
secondName = ""
Else
lAddress = mRange.Address
secondName = mSheet.Cells(mRange.Row, 4).Text
End If
Loop While Not mRange Is Nothing And lAddress <> fAddress And firstName <> secondName
End If
Loop
a.Close
End Sub
|