Page tree

Welcome to FreeSoftwareServers Confluence Wiki

Skip to end of metadata
Go to start of metadata

Most Rules involve moving e-mails into Folders. Outlook will not automatically create folders upon importing rules so some trickery is involved.


  • Export Rules
  • Export list of Folders via:
  • Note: You will have to trim/edit list and save in Excel
Dim gFileName, gCreateTree, gBase

Public Sub ExportFolderTree()
Dim objOutlook
Dim F, Folders
Dim Result
  Set objOutlook = CreateObject("Outlook.Application")
  Set F = objOutlook.Session.PickFolder
If Not F Is Nothing Then
Set Folders = F.Folders
    Result = MsgBox("Do you want to create tree?", vbYesNo + vbDefaultButton2 + vbApplicationModal, "Output Folder Tree")
If Result = 6 Then
gCreateTree = True
gCreateTree = False
End If
    gFileName = GetDesktopFolder() & "\Outlook-Folders.txt"
gBase = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1
    WriteToATextFile (CreateFolderTree(F.FolderPath, F.Name))
LoopFolders Folders
Set F = Nothing
Set Folders = Nothing
Set objOutlook = Nothing
End If
End Sub
Private Function GetDesktopFolder()
Dim objShell
Set objShell = CreateObject("WScript.Shell")
GetDesktopFolder = objShell.SpecialFolders("Desktop")
Set objShell = Nothing
End Function
Private Sub LoopFolders(Folders)
Dim F
For Each F In Folders
WriteToATextFile (CreateFolderTree(F.FolderPath, F.Name))
LoopFolders F.Folders
End Sub
Private Sub WriteToATextFile(OLKfoldername)
Dim objFSO, objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(gFileName, 8, True)
objTextFile.WriteLine (OLKfoldername)
Set objFSO = Nothing
Set objTextFile = Nothing
End Sub
Private Function CreateFolderTree(OLKfolderpath, OLKfoldername)
If gCreateTree = False Then
CreateFolderTree = Mid(OLKfolderpath, 3)
Dim i, x, OLKprefix
i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))
    For x = gBase To i
OLKprefix = OLKprefix & "-"
CreateFolderTree = OLKprefix & OLKfoldername
End If
End Function

  • Create Folders from List on new Client via:
Option Explicit


Public Sub MoveSelectedMessages()
    Dim objParentFolder As Outlook.Folder ' parent
    Dim newFolderName 'As String
    Dim strFilepath
    Dim xlApp As Object 'Excel.Application
    Dim xlWkb As Object ' As Workbook
    Dim xlSht As Object ' As Worksheet
    Dim rng As Object 'Range

    Set xlApp = CreateObject("Excel.Application")
    strFilepath = xlApp.GetOpenFilename
    If strFilepath = False Then
        Set xlApp = Nothing
        Exit Sub
    End If
    Set xlWkb = xlApp.Workbooks.Open(strFilepath)
    Set xlSht = xlWkb.Worksheets(1)
    Dim iRow As Integer
    iRow = 2
Set objParentFolder = Application.ActiveExplorer.CurrentFolder

While xlSht.Cells(iRow, 1) <> ""
newFolderName = xlSht.Cells(iRow, 1)
On Error Resume Next

Dim objNewFolder As Outlook.Folder
Set objNewFolder = objParentFolder.Folders(newFolderName)
If objNewFolder Is Nothing Then
    Set objNewFolder = objParentFolder.Folders.Add(newFolderName)
End If
    iRow = iRow + 1

 ' make new folder the parent
 ' Set objParentFolder = objNewFolder
  Set objNewFolder = Nothing
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing
End Sub

  • Import Rules

  • No labels