05. Данный пример показывает, как можно создать папки в Outlook. В качестве примера загрузки берется Outlook Express с файлами dbx
'==============================================================
' Создание папок с использованием Outlook
Private Sub butExecute_Click()
Dim app As Outlook.Application 'Приложение программы
Dim i As Integer 'Счетчик
Dim myNamespace, myfolder As MAPIFolder, mynewfolder
On Error GoTo 999
Set app = New Outlook.Application
Set myNamespace = app.GetNamespace("MAPI")
Set myfolder = myNamespace.GetDefaultFolder(olFolderInbox)
With Application.FileSearch
.NewSearch
.LookIn = Me.myFolderInternetExpress ' = c:\
.FileName = "*.dbx" ' Выбираем файлы для Outlook Express
.SearchSubFolders = True
If .Execute(SortBy:=msoSortByFileName, _
SortOrder:=msoSortOrderAscending) 0 Then
Me.Progress = "Count=" .FoundFiles.Count vbCrLf
Dim strFile As String
For i = 1 To .FoundFiles.Count
strFile = fGetFileName(.FoundFiles(i))
Me.Progress = Me.Progress strFile vbCrLf
Set mynewfolder = myfolder.Folders.Add(strFile)
DoEvents
Next i
End If
End With
app.Quit 'Закрываем Outlook
MsgBox "Папки созданы!", vbExclamation, "Почта"
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
Resume Next
End Sub
Public Function fGetFileName(strPath As String) As String
Dim fs
On Error GoTo 999
Set fs = CreateObject("Scripting.FileSystemObject")
fGetFileName = fs.GetBaseName(strPath)
Set fs = Nothing
Exit Function
999:
MsgBox Err.Description, vbCritical, strPath
Err.Clear
End Function