Question : Excel macro to create emails from the data aviailable in it.

Hi,

Excel macro to create emails from the data aviailable in it.

When macro run has to check the "Computer name" as in excel in a txt file.

PC2549;emailaddress1
PC1873;emailaddress1
PC1871;emailaddress1

So when the computer name is matched in the txt file. It has to create a new email with the email address in nect to the machine name.
Then put the item name in the Subject. and the body as this

Hi,

Some data in the body " Item name" some other data.

regards
Somename

if the excel computer name in 2 times and item name is different create 2 emails and if item name and computer name are same then create just 1 email.

can anyone please help with this macro.

excel or outlook macro is fine.

regards
sharath

Attachments:

Sample.xls (31 KB) (File Type Details)

sample

Answer : Excel macro to create emails from the data aviailable in it.

The version below should resolve 1 & 2, and very probably 3 as well (tested succesfully on my PC)

1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:



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