Create Folders based on domain name

S

S1lverface

I wand to run though my full inbox and create a subfolder for each of the
domain names therein, but leaving off the extension (.com, .org, .co.uk etc).

For example, my inbox has 100 e-mails from a total of 25 different company
domain names, e.r 10 from [email protected], 11 from [email protected], 5
from [email protected]

I therefore wand a folder called: Walker, Spaceage and Franksome

Thanks again
 
S

S1lverface

Thanks for that.
I need the vba to determine the folder names for me, based on the e-mail
addresses it finds in my inbox, and then create the folders... ? I do not
want to have to manually go through my e-mails myself and decide what folders
are needed

thanks again
 
D

Dmitry Streblechenko

set Inbox = Application.Session.(olFolderInbox)
set NewSubFolder = Inbox.Folders.Add("Your new folder name")

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
S

S1lverface

Thanks again...
I've spent the las hour trying to work it out, and failed.

Below is the code I've used to manually create 5 folder names based on
e-mail domain names from my inbox. I want it to go through the inbox and find
these and others and create me the folders. I'm too new to VBA to understand
the 'loop', 'parse' etc, but I do learn and follow examples well. I'm not
sure where to put or what to put... If you could help that'd be great... Good
news though is that I'm hoping to get an outlook vba programming book for my
Xmas.... Its on my list! But in the meantime, all help is great.....
S1lverface :)


'----------------------------------------------------------
Sub SetUpFolders()
Dim oloUtlook As Outlook.Application
Dim ns As Outlook.NameSpace
Dim itm As Object

On Error Resume Next

Application.ScreenUpdating = False

Set oloUtlook = CreateObject("Outlook.Application")
Set ns = oloUtlook.GetNamespace("MAPI")
Set itm = ns.GetDefaultFolder(olFolderInbox)

itm.Folders.Add ("Fruitmarket")
itm.Folders.Add ("Sales")
itm.Folders.Add ("Blythe")
itm.Folders.Add ("Yeoman")
itm.Folders.Add ("Network")

Set oloUtlook = Nothing
Set ns = Nothing
Set itm = Nothing

MsgBox "All Done"
ThisWorkbook.Close

End Sub
'-----------------------------------------------------
 
D

Dmitry Streblechenko

Loop through all messages in your inbox, read the SenderEmailAddres
property, parse it, add it to a list of folders to create if it is not
already there.
Then loop through the list and create subfolders.

Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
D

Dmitry Streblechenko

Off the top of my head, don't know if it'll actually work:

On error resume next 'to be able to handle errors returened by
Inbox.Folders()
Set oloUtlook = CreateObject("Outlook.Application")
Set ns = oloUtlook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
for each Msg in Inbox.Items
if Msg.Class = 43 Then
address = Msg.SenderEmailAddress
AddrParts = split(address, ".")
if UBound(AddrParts) >= 1 Then
FolderName = AddrParts(UBound(AddrParts)-1) 'second last part
err.Clear
set Folder = Inbox.Folders(FolderName)
if err.Number <> 0 Then
'the folder does not exist
set Folder = Inbox.Folders.Add(FolderName)
End If
End If
End If
next


Dmitry Streblechenko (MVP)
http://www.dimastr.com/
OutlookSpy - Outlook, CDO
and MAPI Developer Tool
 
Top