Copy Outlook folders to another machine

Возникла проблема переноса правил Outlook с машины на машину. Решения, приводимые в интернете с import-export почтового ящика не работают из-за недостатка прав. Единственное решение в этом случае – скрипт на VBA
На основании скрипта выгрузки дописал создание структуры папок.
Ограничения:

• переносятся папки из Inbox в Inbox
• не работают русские буквы в названиях папок
• если папка с таким именем есть, то создание упадет с ошибкой

Ошибки, кроме русских букв, легко устраняются исправлением кода

1. На машине, откуда надо экспортировать файлы заходим в Outlook и оттуда в редактор Visual Basic (Alt-F11).
2. Вставляем в него скрипт, приведенный ниже. Запускаем процедуру ExportFolderNames (F5)
3. В результате работы процедуры на рабочем столе создается файл outlookfolders.txt. Передаем его на машину, где надо создать папки и кладем на рабочий стол
4. На машине-получателе запускаем редактор Visual Basic (Alt-F11), вставляем скрипт и запускаем createFolders
5. Проверяем и радуемся

Текст макроса (особо не причесывал, просто добился работоспособности)

Private myFile As String
Private Structured As Boolean
Private Base As Integer

Private Function getIndent(folderName)
  i = 1
  Do Until Mid(folderName, i, 1) <> "-"
    i = i + 1
  Loop

  getIndent = i - 1

End Function
Public Sub createFolders()
  Dim objNewFolder, objParentFolder As Outlook.Folder
  Dim myFile As String, line, folderName As String

  Dim parentObjects(100) As Outlook.Folder
  ' init for inbox folder
  Set parentObjects(0) = Session.GetDefaultFolder(olFolderInbox)

  myFile = GetDesktopFolder() & "\outlookfolders.txt"
  Open myFile For Input As #1

  Do Until EOF(1)
    Line Input #1, line
     curIndent = getIndent(line)

     If curIndent > 0 Then
       folderName = Right(line, Len(line) - curIndent)
       Set objParentFolder = parentObjects(curIndent - 1)
       'MsgBox ("create folder " + folderName + " in " + objParentFolder.Name + " level=" & curIndent)
       Set objNewFolder = objParentFolder.Folders.Add(folderName)
       Set parentObjects(curIndent) = objNewFolder
     End If
  Loop
  Close #1
  Set objNewFolder = Nothing
  Erase parentObjects

End Sub

Public Sub ExportFolderNames()
  Dim F As Outlook.MAPIFolder
  Dim Folders As Outlook.Folders

  Set F = Session.GetDefaultFolder(olFolderInbox)
  Set Folders = F.Folders

  Dim Result As Integer

  Structured = True


  myFile = GetDesktopFolder() & "\outlookfolders.txt"
  Base = Len(F.FolderPath) - Len(Replace(F.FolderPath, "\", "")) + 1

  WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))

  LoopFolders Folders

  Set F = Nothing
  Set Folders = Nothing
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 As Outlook.Folders)
  Dim F As Outlook.MAPIFolder

  For Each F In Folders
    WriteToATextFile (StructuredFolderName(F.FolderPath, F.Name))
    LoopFolders F.Folders
  Next
End Sub

Private Sub WriteToATextFile(OLKfoldername As String)
  fnum = FreeFile()

  Open myFile For Append As #fnum
    Print #fnum, OLKfoldername
  Close #fnum
End Sub

Private Function StructuredFolderName(OLKfolderpath As String, OLKfoldername As String) As String
  If Structured = False Then
    StructuredFolderName = Mid(OLKfolderpath, 3)
  Else
    Dim i As Integer
    i = Len(OLKfolderpath) - Len(Replace(OLKfolderpath, "\", ""))

    Dim x As Integer
    Dim OLKprefix As String
    For x = Base To i
      OLKprefix = OLKprefix & "-"
    Next x

    StructuredFolderName = OLKprefix & OLKfoldername
  End If
End Function