Hi . I would need some help to create a code to import emails from Outlook to excel

[antokout]

Hello guys i am trying to create a code that it could search for a subject word from my Outlook inbox and put all emails with this word subject into a worksheet and count each subject of these emails...


Thanks a lot

[Kenneth Hobs]

I don't know what you mean by "put all emails". If you mean put the body of the email into a cell, that won't always fit. The body may contain objects so fitting those into a cell would be challenge. If it has attachment(s), that is another issue too.

You might consider adding an Outlook Rule to move the emails to another folder. Of course a macro could move the emails to a folder or create the folder and move.

[antokout]

No I mean to put all emails subjects contains the word i choose from subjects For example i want to search emails to put in with the word "Upgrade" i want to show me when i run it something like this :
A B
Count Subject
5 Upgrade Dslam agg.thes
3 Upgrade switch asw.thes9ka.


I mean to search first specific word in each subject and just put into excel worksheet emails subjects with this word and a counter

[Kenneth Hobs]

How is count computed? What confuses me is that you have a 2 different counts but just one subject for each count.

Is the match word to subject case sensitive?

Sometimes, a simple workbook attached makes things more clear. Click Go Advanced button in lower right, and then Manage Attachments link below the reply box to upload a file.

[antokout]

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Dim olItem As Object
Dim dic As Dictionary
Dim i As Long
Dim Subject As String

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set dic = New Dictionary

For Each olItem In olFldr.Items
If olItem.Class = olMail Then
Subject =olItem.Subject
If dic.Exists(Subject) Then dic(Subject) = dic(Subject) + 1 Else dic(Subject) = 1
End If
Next olItem


With ActiveSheet
.Columns("A:B").Clear
.Range("A1:B1").Value = Array("Count", "Subject")
For i = 0 To dic.Count - 1
.Cells(i + 2, "A") = dic.Items()(i)
.Cells(i + 2, "B") = dic.Keys()(i)
Next
End With
End Sub


this is my code but this code sent all emails on a workbook. I need to make this code with searching first a specific word on subject and seperate to different worksheets

[antokout]

If you could help me i would be grateful
Thank you

[p45cal]

untested, perhaps:

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Dim olItem As Object
Dim dic As Dictionary
Dim i As Long
Dim Subject As String
Dim SoughtWord As String

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set dic = New Dictionary

SoughtWord = "Upgrade"

For Each olItem In olFldr.Items
  If olItem.Class = olMail Then
    Subject = olItem.Subject
    If InStr(Subject, SoughtWord, vbTextCompare) > 0 Then
      If dic.Exists(Subject) Then dic(Subject) = dic(Subject) + 1 Else dic(Subject) = 1
    End If
  End If
Next olItem


With ActiveSheet
  .Columns("A:B").Clear
  .Range("A1:B1").Value = Array("Count", "Subject")
  For i = 0 To dic.Count - 1
    .Cells(i + 2, "A") = dic.Items()(i)
    .Cells(i + 2, "B") = dic.Keys()(i)
  Next
End With

[antokout]

Run-time error '13'

Type mismatch
on line If InStr(Subject, SoughtWord, vbTextCompare) > 0 Then

[p45cal]

Sorry, try:
If InStr(1, Subject, SoughtWord, vbTextCompare) > 0 Then

[antokout]

I think its worked i have check from emails if i received the right number of emails for this subject
Thanks a lot mate

[antokout]

This code export all emails from inbox right? (with this subject word)

[p45cal]

This code export all emails (with this subject word)

It doesn't export anything.
It copies the Subject (text) of email items containing the string sought (Upgrade) and then groups identical Subjects giving a count of each one.

from inbox right?

If the inbox is the result of:
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
which it looks very much like it does, then yes.

[antokout]

yy that was i mean with export copy the subject but i think that it doesnt because i try with a word "Peakflow"
with this word i have at least 100 emails received and it copies only 5

[antokout]

And if i want to copy and from inbox and from some specific folders?

[p45cal]

some specific folders?

Then you'll need to know the folder hierarchy/names. There may be some sub-folders under the inbox, or possibly some other folders in your olNs object.
I'm not especially conversant with the Outlook object model so perhaps browsing http://www.vbaexpress.com/forum/foru...8-Outlook-Help would help?

[Kenneth Hobs]

Setting the Outlook folder can be somewhat straightforward or a little odd. Here is a short example. Be sure to set the References as commented.

If you don't know the path, as shown at the end of the SetFolder routine, try selecting the folder in Outlook, and then uncomment the 3 consecutive comments. View Immediate Window results after a run.

'https://www.extendoffice.com/documents/outlook/3747-outlook-auto-download-save-attachments-to-folder.html'or
'https://www.excelguru.ca/forums/showthread.php?9073-VBA-to-automatically-extract-email-attachments-and-save-them-into-a-specific-file


Sub SetFolder()  'Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
  Dim OL As Outlook.Application
  Dim objRecipient As Outlook.Recipient, objAction As Outlook.Action
  'Dim objFolder As Outlook.MAPIFolder
  Dim objFolder As Outlook.Folder 'For Gmail Task's folder
  
  Set OL = CreateObject("Outlook.Application")
  
  'Set objFolder = OL.GetNamespace("MAPI").GetDefaultFolder(olFolderTasks) 'olFolderTasks=13
  'Set objFolder = OL.GetNamespace("MAPI").PickFolder
  'Debug.Print objFolder.Name, objFolder.FolderPath


  Set objFolder = GetFolderPath("\\ken@gmail.com\Puppy\Pics", OL)
  Debug.Print objFolder.Name, objFolder.FolderPath
End Sub


'Similar to, http://www.slipstick.com/developer/working-vba-nondefault-outlook-folders/#GetFolderPath
''Early Binding: Tools > References > Microsoft Outlook xx.0 Object Library > OK
Function GetFolderPath(ByVal FolderPath As String, oApp As Outlook.Application) As Outlook.Folder
    Dim oFolder As Outlook.Folder
    Dim FoldersArray As Variant
    Dim i As Integer
     
    On Error GoTo GetFolderPath_Error
    If Left(FolderPath, 2) = "\\" Then
        FolderPath = Right(FolderPath, Len(FolderPath) - 2)
    End If
    'Convert folderpath to array
   FoldersArray = Split(FolderPath, "\")
    'Set oFolder = Application.Session.Folders.Item(FoldersArray(0))
   Set oFolder = oApp.Session.Folders.Item(FoldersArray(0))
    If Not oFolder Is Nothing Then
        For i = 1 To UBound(FoldersArray, 1)
            Dim SubFolders As Outlook.Folders
            Set SubFolders = oFolder.Folders
            Set oFolder = SubFolders.Item(FoldersArray(i))
            If oFolder Is Nothing Then
                Set GetFolderPath = Nothing
            End If
        Next
    End If
    'Return the oFolder
   Set GetFolderPath = oFolder
    Exit Function
     
GetFolderPath_Error:
    Set GetFolderPath = Nothing
    Exit Function
End Function

[antokout]

Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFldr As Outlook.MAPIFolder
Dim olMailItem As Outlook.MailItem
Dim olItem As Object
Dim dic As Dictionary
Dim i As Long
Dim Subject As String
Dim SoughtWord As String

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
Set olFldr = olNs.GetDefaultFolder(olFolderInbox)
Set dic = New Dictionary

SoughtWord = "Upgrade"

For Each olItem In olFldr.Items
If olItem.Class = olMail Then
Subject = olItem.Subject
If InStr(Subject, SoughtWord, vbTextCompare) > 0 Then
If dic.Exists(Subject) Then dic(Subject) = dic(Subject) + 1 Else dic(Subject) = 1
End If
End If
Next olItem


With ActiveSheet
.Columns("A:B").Clear
.Range("A1:B1").Value = Array("Count", "Subject")
For i = 0 To dic.Count - 1
.Cells(i + 2, "A") = dic.Items()(i)
.Cells(i + 2, "B") = dic.Keys()(i)
Next
End With



If i worked on this and change this line
Set olFldr = olNs.GetDefaultFolder(olFolderInbox) and do something like this
Set olFldr = olNs.GetDefaultFolder(olFolderInbox).Folders("name of folder").Folders("name of folder") ? it shouldnt work?

[Kenneth Hobs]

No.

[antokout]

so the code you send me what will show me on excel?

[antokout]

Set objFolder = GetFolderPath("\\ken@gmail.com\Puppy\Pics", OL)
On this line i should choose the folder i want?