Extracting information from Outlook

[pupsia]

Hello all,

For example I have an mail box:
name: TestingEML
@ name: testing.eml@test.com

The macro works like this:

1. Run Macro
2. Box with all email boxes pops up
3. Select the folder you need to extract emails from manually
4. The macro extracts all emails from the selected folder into a "Report" sheet
5. Done

There are some other stuff that is being done, but that is not that important at the moment.

My macro works fine, no problems, BUT, I need to add an additional column and for some reason I cant find the right name for the data.

Right now it extracts this information:
report.Range("A" & n) = olMail.Subject
report.Range("B" & n) = olMail.SenderName
report.Range("C" & n) = olMail.To & "; " & olMail.CC
report.Range("D" & n) = olMail.Parent.Name
report.Range("E" & n) = olMail.Categories
report.Range("F" & n) = olMail.ReceivedTime
report.Range("G" & n) = olMail.ConversationID

I`m trying to add something like this:
report.Range("H" & n) = olMail.Account

I work with multiple mailboxes, and sometimes when I have a lot of reports, it gets confusing from what exact mail box is that report. I have olMail.Parent.Name, so I know what folder I extracted.

For some reason I cant find way way to name olMail.??? so it would give me "TestingEML" in the H column.

Not sure if I make any sense..

Any advice please?

 

[Fazza]

May need to see the code. I'm guessing there is something like

for each olAddress in olNameSpace.Folders
for each olFolder in olAddress.Folders
maybe for each olSubFolder in olFolder.Folders
for each olMail in olFolder.items

then there will be
email address : olAddress.Name
folder : olFolder.Name
subfolder : olSubFolder.Name

HTH

 

[pupsia]

The code for extracting email would be this (it is from a few sub parts).
These are the main parts. Some additional calculation, deletion, coloring, sorting and so on are mostly in other parts.

Sub Launch_Pad()

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
     
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Application.ScreenUpdating = False
    If ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row > 2 Then n = ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row Else n = 2
    Set report = ThisWorkbook.Sheets("Report")
    'n = 2
    'Cells.ClearContents
     
    Call ProcessFolder(olFolder)
    Call DovydasUpgrade
    'Call statistika_tutita
     
    Set olNS = Nothing
    Set olFolder = Nothing
    Set olApp = Nothing
    Set olNS = Nothing
    
 '   Add_Email_Name_in_H
    
    Application.ScreenUpdating = True
    AppActivate Application.Caption 'grazina exceli i prieki
    MsgBox "Completed."
End Sub

Sub ProcessFolder(olfdStart As Outlook.MAPIFolder)
    Dim subfolderis As Outlook.MAPIFolder
    Dim olFolder As Outlook.MAPIFolder
    Dim olMail As Outlook.MailItem
    'Set report = ThisWorkbook.Sheets("Report")
      
   
    week = report.OptionButtons("Option Button 2").Value 'for week
    daily = report.OptionButtons("Option Button 3").Value 'for day
     
    If n = 2 Then
        report.Range("A" & n).Value = "Subject"
        report.Range("B" & n).Value = "SenderName"
        report.Range("C" & n).Value = "To"
        report.Range("D" & n).Value = "Folder name"
        report.Range("E" & n).Value = "Categories"
        report.Range("F" & n).Value = "ReceivedTime"
        report.Range("G" & n).Value = "Conversation ID"
        
        report.Range("H" & n).Value = "Trackable outbox"
        
        report.Range("A2:H2").Style = "Accent1"
    End If




 With Worksheets("Report").Range("H:H").Borders(xlEdgeRight)
    .LineStyle = xlContinuous
    .Weight = xlMedium
 End With


                    
'On Error Resume Next
'AppActivate Application.Caption ' grazina excelio langa kaip active
    If week = xlOn Then
    AppActivate Application.Caption ' grazina excelio langa kaip active
        SiosSavNr = WeekNumberAbsolute(Format(Now()))
        SavaitesNR = InputBox(Prompt:="Pleas enter Week # as today we have " & SiosSavNr & "th one.", Title:="Week number?", Default:=SiosSavNr)
        
        Call laiskams(olfdStart, SavaitesNR) ' kviecia likusias funkcijas
    End If
    
    
    If daily = xlOn Then Call laiskams(olfdStart, SavaitesNR)
    report.Columns("F:F").NumberFormat = "d/m/yy h:mm;@"
    report.Range("A2:H2").AutoFilter
    Set olMail = Nothing
    Set olFolder = Nothing
    'Set olObject = Nothing
End Sub

Function laiskams(olfdStart, SavaitesNR)
    Dim olObject As Object
    Set report = ThisWorkbook.Sheets("Report")
    week = report.OptionButtons("Option Button 2").Value 'for week
    daily = report.OptionButtons("Option Button 3").Value 'for day




            For Each olObject In olfdStart.Items                            'kala per visus root item'us
              If TypeName(olObject) = "MailItem" Then
                'If Err > 0 Then Err.Clear: GoTo kitas31
                    Application.StatusBar = olObject.Parent.Name & " " & olObject.ReceivedTime


                    If daily = xlOn Then
                        If Val(DateDiff("d", olObject.ReceivedTime, Now)) <= 7 Then Call MailItemExport(olObject) 'tikrina kad per 7 dienas butu
                    End If
                    If week = xlOn Then
                        If WeekNumberAbsolute(olObject.ReceivedTime) = SavaitesNR Then Call MailItemExport(olObject)
                    End If
              End If
kitas31:
            Next olObject
            Call folderiams(olfdStart, SavaitesNR)
End Function

Function MailItemExport(olMail As Outlook.MailItem)
    
    n = n + 1
    Application.StatusBar = olMail.ReceivedTime
    report.Range("A" & n) = olMail.Subject
    report.Range("B" & n) = olMail.SenderName
    report.Range("C" & n) = olMail.To & "; " & olMail.CC
    report.Range("D" & n) = olMail.Parent.Name
    report.Range("E" & n) = olMail.Categories
    report.Range("F" & n) = olMail.ReceivedTime
    report.Range("G" & n) = olMail.ConversationID
    
    report.Range("H" & n) = olMail.DisplayName
    


    'report.Range("N" & n) = olMail.Parent.Name
    'report.Range("O" & n) = olMail.SentOnBehalfOfName
    'report.Range("P" & n) = olMail.ReplyRecipientNames
    report.Range("R" & n) = olMail.LastModificationTime


End Function

 

[Fazza]

so you're OK now?

 

[pupsia]

Just finished testing a few things out. Nothing I tried worked unfortunately

Tried stuff like this:
report.Range("H" & n) = olMail.Name
report.Range("H" & n) = olFolder.Name

 

[Fazza]

olFolder is in Launch_Pad

I don't see what it does in ProcessFolder - it looks like the code has been chopped up a bit. Maybe something is missing?

Suggest looking further at olFolder
Maybe everytime it is used debug.print olFolder.Name
and work out what is happening

cheers

 

[pupsia]

At the moment I`m trying to at least get the email box name, but something is not right..
I`m trying to run the macro, select a random folder, and have the MsgBox tell me from what email box did that folder come from.
I think i Set something incorrectly...

    Dim olApp As Outlook.Application    
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olAddress As Outlook.Namespace
     
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    Set olAddress = olNS.Folders
    
    Application.ScreenUpdating = False
    If ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row > 2 Then n = ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row Else n = 2
    Set report = ThisWorkbook.Sheets("Report")
    'n = 2
    'Cells.ClearContents
    
    MsgBox olAddress.Name

 

[pupsia]

Is there a method or a function that would let you to get the mail box name based on the folder?
Trying something like this. But doesn't seem to work.
Maybe I need to get some ID from the selected folder? And the based on ID get the mail box name?

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    
    Dim myExplorer As Outlook.Explorer
    Dim myFolder As Outlook.Folder
     
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    
    Application.ScreenUpdating = False
    If ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row > 2 Then n = ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row Else n = 2
    Set report = ThisWorkbook.Sheets("Report")


    MsgBox olNS.GetAddressEntryFromID(olFolder)

 

[pupsia]

Also tired to get an ID, but guessing that is a wrong way of doing it.

    olFolder.ID
    MsgBox olNS.GetAddressEntryFromID(ID)

 

[pupsia]

Okay, I sure there should be an easier and more correct way of doing this, BUT, this one works

    Dim olApp As Outlook.Application
    Dim olNS As Outlook.Namespace
    Dim olFolder As Outlook.MAPIFolder
    Dim olBoxName As Outlook.MAPIFolder
    
    Dim myExplorer As Outlook.Explorer
    Dim myFolder As Outlook.Folder
     
    Set olApp = Outlook.Application
    Set olNS = olApp.GetNamespace("MAPI")
    Set olFolder = olNS.PickFolder
    
    Application.ScreenUpdating = False
    If ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row > 2 Then n = ThisWorkbook.Sheets("Report").UsedRange.SpecialCells(xlCellTypeLastCell).Row Else n = 2
    Set report = ThisWorkbook.Sheets("Report")


    MsgBox olFolder.FolderPath
    
    If olFolder.Parent.Parent = "Mapi" Then Set olBoxName = olFolder.Parent
    If olFolder.Parent.Parent.Parent = "Mapi" Then Set olBoxName = olFolder.Parent.Parent
    If olFolder.Parent.Parent.Parent.Parent = "Mapi" Then Set olBoxName = olFolder.Parent.Parent.Parent
    If olFolder.Parent.Parent.Parent.Parent.Parent = "Mapi" Then Set olBoxName = olFolder.Parent.Parent.Parent.Parent
    If olFolder.Parent.Parent.Parent.Parent.Parent.Parent = "Mapi" Then Set olBoxName = olFolder.Parent.Parent.Parent.Parent.Parent
    
    MsgBox olBoxName