Extract email from specific sender from outlook

[exceluser9]

Hi Team,

Im using below vbs code to extract emails from outlook. Please could you help me to amend code extract email from specific sender? example home@gmail.com

Sub GetMailInfo()

Dim results() As String

' get contacts
results = ExportEmails(True)

' paste onto worksheet
Range(Cells(1, 1), Cells(UBound(results), UBound(results, 2))).Value = results

MsgBox "Completed"
End Sub

Function ExportEmails(Optional headerRow As Boolean = False) As String()

Dim objOutlook As Object ' Outlook.Application
Dim objNamespace As Object ' Outlook.Namespace
Dim strFolderName As Object
Dim objMailbox As Object
Dim objFolder As Object
Dim mailFolderItems As Object ' Outlook.items
Dim folderItem As Object
Dim msg As Object ' Outlook.MailItem
Dim tempString() As String
Dim i As Long
Dim numRows As Long
Dim startRow As Long
Dim jAttach As Long ' counter for attachments
Dim debugMsg As Integer

' select output results worksheet and clear previous results
Sheets("Outlook Results").Select
Sheets("Outlook Results").Cells.ClearContents
Range("A1").Select

Set objOutlook = CreateObject("Outlook.Application")
'MsgBox objOutlook, vbOKOnly 'for debugging
Set objNamespace = objOutlook.GetNamespace("MAPI")
'MsgBox objNamespace, vbOKOnly 'for debugging
'Set objInbox = objNamespace.GetDefaultFolder(olFolderInbox)
'MsgBox objInbox, vbOKOnly 'for debugging
Set strFolderName = objNamespace.PickFolder
Set mailFolderItems = strFolderName.Items
mailFolderItems.Sort "[ReceivedTime]", False

' if calling procedure wants header row
If headerRow Then
startRow = 1
Else
startRow = 0
End If

numRows = mailFolderItems.Count

' resize array
ReDim tempString(1 To (numRows + startRow), 1 To 100)
mailFolderItems.Sort "[ReceivedTime]", False
' loop through folder items
For i = 1 To numRows
Set folderItem = mailFolderItems.Item(i)

If IsMail(folderItem) Then
Set msg = folderItem
End If

With msg
tempString(i + startRow, 1) = .SenderName
tempString(i + startRow, 2) = .ReceivedTime
tempString(i + startRow, 3) = .Subject
'tempString(i + startRow, 4) = Left$(.Body, 200) ' throws error without limit
'tempString(i + startRow, 5) = .SenderEmailAddress
'tempString(i + startRow, 6) = .SentOn


End With

' adding file attachment names where they exist - added by JP
If msg.Attachments.Count > 50 Then

For jAttach = 1 To msg.Attachments.Count
tempString(i + startRow, 39 + jAttach) = msg.Attachments.Item(jAttach).DisplayName
Next jAttach

End If

Next i

' first row of array should be header values
If headerRow Then


tempString(1, 1) = "SenderName"
tempString(1, 2) = "ReceivedTime"
tempString(1, 3) = "subject"
'tempString(1, 4) = "Body"
'tempString(1, 5) = "SenderEmailAddress"
'tempString(1, 6) = "SentOn"
End If

ExportEmails = tempString

' apply pane freeze and filtering

Range("A2").Select
ActiveWindow.FreezePanes = True
Rows("1:1").Select


'Selection.AutoFilter

End Function

Function IsMail(itm As Object) As Boolean
IsMail = (TypeName(itm) = "MailItem")
End Function