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.

https://superuser.com/questions/1471615/outlook-automatically-create-folders-when-importing-rules/1471914#1471914

Steps:

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

'https://www.extendoffice.com/documents/outlook/4099-outlook-print-list-of-folders.html
 
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
Else
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
Next
End Sub
 
Private Sub WriteToATextFile(OLKfoldername)
Dim objFSO, objTextFile
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objTextFile = objFSO.OpenTextFile(gFileName, 8, True)
objTextFile.WriteLine (OLKfoldername)
objTextFile.Close
Set objFSO = Nothing
Set objTextFile = Nothing
End Sub
 
Private Function CreateFolderTree(OLKfolderpath, OLKfoldername)
If gCreateTree = False Then
CreateFolderTree = Mid(OLKfolderpath, 3)
Else
Dim i, x, OLKprefix
i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))
 
    For x = gBase To i
OLKprefix = OLKprefix & "-"
Next
 
CreateFolderTree = OLKprefix & OLKfoldername
End If
End Function

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

'https://www.slipstick.com/developer/code-samples/create-outlook-folders-list-folder-names/

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
        xlApp.Quit
        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
Wend
     
    xlWkb.Close
    xlApp.Quit
    Set xlWkb = Nothing
    Set xlApp = Nothing
    Set objParentFolder = Nothing
End Sub

  • Import Rules

  • No labels