CODEWITHSUNDEEP
vbaoutlookoutlook-2010
Josef Miller
Josef Miller

Reputation: 113

Outlook macro to collect/extract data from "Subject field" of numerous messages into a text file

Our firewall users send messages requesting unblocking certain websites that they believe shouldn't be blocked. Their messages subject fields contain such websites urls. In fact, one url is sent per message. Due to the increase in number of users, hundreds or may be thousands of messages are expected to be received per day.

Is there an Outlook macro that will collect or extract such urls (from received messages subject fields) into one single text file without having to open any message?

Deeply appreciating any assistance with this matter.

Thanks in advance

Upvotes: 1

Views: 24160

Answers (2)

Javier
Javier

Reputation: 9

here is the solution to your problem :)

When you make a For Each Outlook it enumerating each email. If you move any email within the loop For Each, then Outlook changes the number of all the emails of the folder but doesn't change the iteration number of your loop. This results in several messages that will not be read.

Solution is to make a loop starting from the last email as mentioned here Outlook macro to collect/extract data from "Subject field" of numerous messages into a text file

CODE: Replace (For Each InboxMsg In Inbox.Items) with

For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards Set InboxMsg = Inbox.Items(i)

Upvotes: 0

Kazimierz Jawor
Kazimierz Jawor

Reputation: 19067

Please write this code to your Outlook VBA module. Change some names of folders and destination file in some lines below. For other information see comments inside sub.

Sub Retrieve_http()

'our Outlook folder- deifinitions
    Dim myItem As MailItem
    Dim myFolder As Folder
    Dim myNamespace As NameSpace
    Set myNamespace = Application.GetNamespace("MAPI")
    'put your folders name here
    '1st one is store folder which should refer to [email protected]
    'second is possibly 'inbox folder'
    Set myFolder = myNamespace.folders("[email protected]").folders("inbox")

'destination file
    Dim resFile As String
        resFile = "c:\Users\Kazik\Desktop\httpRequest.txt"
    Dim ff As Byte
        ff = FreeFile()
    'creating or opening it- each time you run this macro we will append data
    'until deletion of either file or its content
    Open resFile For Append As #ff

    For Each myItem In myFolder.items
        If InStr(1, myItem.Subject, "http://") > 0 And _
            InStr(1, myItem.Subject, "classified under:") > 0 Then
                'write to file
                Write #ff, myItem.Subject

        End If
    Next
    Close #ff
End Sub

EDIT to include appropriate deletion process and reference of the code to the picture.

The following picture present Outlook window (Polish version) where: Business Mail is one of Top Folders (which refers to separate .pst file). 'Skrzynka odbiorcza' is just 'inbox'.

enter image description here

Code which searches for certain emails, retrieves subject of emails and deletes emails afterwards looks as follow:

Sub Retrieve_http()

'our Outlook folder- deifinitions
    Dim myItem As MailItem
    Dim myFolder As Folder
    Dim myNamespace As NameSpace
    Set myNamespace = Application.GetNamespace("MAPI")
    'put your folders name here
    Set myFolder = myNamespace.folders("Business Mail").folders("skrzynka odbiorcza")

'destination file
    Dim resFile As String
        resFile = "c:\Users\Kazik\Desktop\httpRequest.txt"
    Dim ff As Byte
        ff = FreeFile()
    'creating or opening it- each time you run this macro we will append data
    'until deletion of either file or its content
    Open resFile For Append As #ff
    Dim i!
    For i = myFolder.items.Count To 1 Step -1
        If InStr(1, myFolder.items(i).Subject, "http://") > 0 And _
            InStr(1, myFolder.items(i).Subject, "classified under") > 0 Then
                'write to file
                Write #ff, myFolder.items(i).Subject
                'delete item
                myFolder.items(i).Delete
        End If
    Next
    Close #ff
End Sub

Upvotes: 3

Related Questions