Amend VBA code to extract details from outlook - Urgent help required

[exceluser9]

Hi Team,

Im using below VBA code to extract emails from outlook. However, it extracts all emails. I want the code to extract only specific emails with below subjects. For the last 2 emails the timing keeps changing on the email but rest remains same until 28 characters

View attachment 82619MIKONSbarphone- GP hub Status
GPRS System Availability ETA - 08:58
GPRS System Availability ETA - 08:38

Whenever i run the macro it should extract the current days email and paste in the excel and when i run the macro next day it should paste the data from the following row and retain the existing data

On Sunday we get only this email View attachment 82619MIKONSbarphone- GP hub Status

When i run the macro on Monday it should extract the data for Saturday, Sunday & Monday because we dont work on weekends.

Also please note the data should be pasted in sequence based on the date and time. The current code which im using doesnt do that

Thanks in advance for your help

Option Explicit
' Got this code from [URL]http://superuser.com/questions/816289/exporting-attachment-file-name-email-metadata-from-outlook-to-excel[/URL]
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

  ' 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)

  ' 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

 

[Peter_SSs]

I probably cannot help with your actual question, but a few suggestions that might help you get other people to help.

1. Regarding the 'Urgent' component of your thread title. I suggest that you refer to g. and h. of point 5 in the Guidelines
2. I suggest that you update your Account details (click your user name at the top right of the forum) so helpers always know what Excel version(s) & platform(s) you are using as the best solution often varies by version. (Don’t forget to scroll down & ‘Save’)
3. When posting vba code in the forum, please use the available code tags. It makes your code much easier to read/debug & copy. My signature block below has more details. I have added the tags for you this time.