Sub CloseOutlook()
Dim OL As Object
On Error Resume Next
Set OL = GetObject(, "Outlook.Application")
On Error GoTo 0
If OL Is Nothing Then
'MsgBox "Outlook is not running!"
Else
OL.Quit
End If
End Sub
Sub Search_Inbox()
'Optimize Macro Speed
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.Calculation = xlCalculationManual
Dim wb As Workbook
'Trying to close outlook first
CloseOutlook
'Trying to close the target excel file
'now let's see if the workbook where the data to be pasted is open or not
Dim status As Boolean
status = IsWorkBookOpen("C:\Users\sourav\Desktop\data.xlsm")
If status = True Then
Workbooks("data.xlsm").Close SaveChanges:=True
End If
Dim myOlApp As New Outlook.Application
Dim myNameSpace As Outlook.Namespace
Dim myInbox As Outlook.MAPIFolder
Dim myitems As Outlook.Items
Dim myItem As Object
Dim Found As Boolean
Dim atmt As Outlook.Attachment
Dim MyAr() As String
Dim address As String
Dim message As String
Dim ws As Worksheet
Dim aCell As Range, Rng As Range
Dim col As Long, lRow As Long
Dim colName As String
On Error Resume Next
Set myNameSpace = myOlApp.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myitems = myInbox.Items
Found = False
For Each myItem In myitems
If myItem.Class = olMail Then
If InStr(1, myItem.Subject, "macro") > 0 Then
'MsgBox ("Found")
For Each atmt In myItem.Attachments
If atmt.FileName = "macro.txt" Then
atmt.SaveAsFile "D:\" & atmt.FileName
'MsgBox (myItem.SenderEmailAddress)
'saving the mail body in an array
MyAr = Split(myItem.Body, vbCrLf)
For i = LBound(MyAr) To UBound(MyAr)
'~~> This will give you the contents of your email
'~~> on separate lines
'MsgBox (MyAr(i))
If MyAr(i) <> "" Then
message = message + MyAr(i)
End If
Next i
'Now trying to write the message and the sender address in an existing excel file
'First trying to close the file if it is already open
On Error Resume Next
Workbooks("data.xlsm").Close SaveChanges:=True
'now trying to open the file
Set wb = Workbooks.Open("C:\Users\sourav\Desktop\data.xlsm")
'now finding the spicific column with some word or words
Set ws = wb.Sheets("Sheet2")
With ws
Set aCell = .Range("A1:P1").Find(What:="Mail*", LookIn:=xlValues, LookAt:=xlWhole, _
MatchCase:=False, SearchFormat:=False)
If Not aCell Is Nothing Then
col = aCell.Column
colName = Split(.Cells(, col).address, "$")(1)
'MsgBox (colName)
lRow = .Range(colName & .Rows.count).End(xlUp).Row
'MsgBox (lRow)
'~~> This is your range
'Set Rng = .Range(colName & "8:" & colName & lRow)
'MsgBox (Rng.address)
'~~> If not found
'Now find the blank cell in the column found earlier
Set Rng = .Range(colName & lRow)
Rng.Select
Range(Selection.End(xlDown)).Select
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = myItem.SenderEmailAddress
If ActiveCell.Offset(0, 1) = "" Then
ActiveCell.Offset(0, 1).Value = message
End If
ws.Columns.AutoFit
Else
' MsgBox "Mail Not Found"
End If
End With
On Error Resume Next
wb.Close SaveChanges:=True
Set wb = Nothing
Set ws = Nothing
'MsgBox ("Done")
End If
message = ""
Next
Found = True
End If
End If
Next myItem
'If the subject isn't found:
If Not Found Then
' NoResults.Show
MsgBox ("Task Failed")
End If
myOlApp.Quit
Set myOlApp = Nothing
'Reset Macro Optimization Settings
Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub
