LEADERSOFT.ru Разработка на заказ программ и сайтов
ЕСЛИ БАЗА ВАМ НУЖНА В ЛИДЕРСОФТ ЗАЙДИ СПЕРВА!
Все примеры Microsoft Access - VBA
























































05. Данный пример показывает, как можно создать папки в Outlook. В качестве примера загрузки берется Outlook Express с файлами dbx

Все примеры Microsoft Access
'==============================================================
'  Создание папок с использованием Outlook
Private Sub butExecute_Click()
Dim app As Outlook.Application  'Приложение программы
Dim 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 StringAs 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