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
20. Для округления математических полей в форме можно использовать функцию формат.
Private Sub Form_Open(Cancel As Integer)
Me.myFormat = "0.00"
Me.myИтого = Format(Me.myNumber, Me.myFormat)
End Sub
При разработке интерфейса Вам может потребоваться использовать правую кнопку мыши для вызова контекстного меню. Как это сделать программным способом смотрите в этом разделе.
Dim WithEvents myCombo As CommandBarComboBox ' Обработка событий
Const strMenu As String = "Правая кнопка"
Private Sub Form_Open(Cancel As Integer)
' Определяем название
On Error Resume Next
CommandBars.Item(strMenu).Delete
Err.Clear
' Создаем панель меню
On Error GoTo 999
Dim myBar As CommandBar
Set myBar = CommandBars.Add(strMenu, msoBarPopup, , False)
' Добавляем 1 кнопку
Dim But As CommandBarButton
Set But = myBar.Controls.Add(msoControlButton)
With But
.Style = msoButtonCaption ' Выбираем стандартный тип
.FaceId = 1 ' Устанавливаем код кнопки
.Caption = "Кнопка 1" ' Называем кнопку
.OnAction = "=msgBox('Привет!')" ' Определяем программу
End With
' Создаем список в меню
Set myCombo = myBar.Controls.Add(msoControlDropdown, , 1)
With myCombo
.BeginGroup = True
.Caption = "Cписок: "
.Style = msoComboLabel
.AddItem "Строка 1"
.AddItem "Строка 2"
.ListIndex = 2 ' Устанавливаем 2 вариант
.DropDownWidth = -1 ' Выбираем ширину по самому длинному
End With
' Добавляем кнопки меню из других панелей
' (для нахождения кодов смотрите пример 05)
'
With CommandBars("Menu Bar")
.FindControl(, 523, , , True).Copy myBar ' Схема данных
.FindControl(, 210, , , True).Copy myBar ' Сортировка по возрастанию
.FindControl(, 211, , , True).Copy myBar ' Сортировка по убыванию
.FindControl(, 19, , , True).Copy myBar ' Копировать в буфер
End With
' Просмотр данных из текущей позиции
' myBar.ShowPopup
Exit Sub
999:
MsgBox Err.Description
End Sub
'==============================================================
' Отключение
Private Sub butOld_Enter()
Me.ShortcutMenuBar = ""
End Sub
'==============================================================
' Включение меню
Private Sub butNew_Enter()
Me.ShortcutMenuBar = strMenu
End Sub
'==============================================================
' Включение меню
Private Sub myCombo_Change(ByVal ctrl As CommandBarComboBox)
MsgBox "Текст: " ctrl.Text
End Sub
01. Данный пример показывает вам, как можно загрузить все рисунки из каталога в базу данных. Обратите внимание на Dir("\*.bmp", vbNormal) - таким простейшим и древним способом можно получить все файлы из каталога. Рекомендации для хранения рисунков. Лучше использовать отдельные файлы, хотя в некоторых случаях это может пригодится.
' Загрузить рисунки из файла в таблицу
' (Для работы программы в папке должны быть файлы *.bmp)
'
Private Sub butExecute_Click()
Dim myBmp As String, myDir As String
On Error GoTo 999
' Папка для поиска
myDir = Application.CurrentProject.Path
' Находим файл с расширением bmp
myBmp = Dir(myDir "\*.bmp", vbNormal)
Do While Len(myBmp) 0 'Проверяем файл
Me.Файл = myBmp 'Файл bmp
Me.Папка = myDir 'Каталог
Me.Рисунок.OLETypeAllowed = acOLEEmbedded 'Назначаем режим вставки
Me.Рисунок.SourceDoc = Me.Папка "\" Me.Файл 'Путь файла
Me.Рисунок.Action = acOLECreateEmbed 'Вставляем объект в таблицу
'Переход к новой записи
myBmp = Dir 'Новый файл bmp
DoCmd.RunCommand acCmdRecordsGoToNew ' Переходим на новую запись
Loop
DoCmd.RunCommand acCmdRecordsGoToFirst 'Начало записей
MsgBox "Рисунки загружены!", vbExclamation, "Графика"
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
End Sub
06. Файл UDL - это файл строки соединения с базой данных. Эти функции показывают, как можно его создать из VBA
Option Compare Database
Option Explicit
'==============================================================
' ADO. Читаем файл UDL
Private Sub butRead_Click()
' Строка файла udl
Dim strUdl As String ' Файл
strUdl = Application.CurrentProject.Path "\la_ado.udl"
' Открываем файл
Dim fs, f
Const ForReading = 1
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.OpenTextFile(strUdl, ForReading, False, -1) ' Читаем файл Unicode
' Читаем данные из файла
Dim strCnn As String
strCnn = f.read(FileLen(strUdl))
' Закрываем файл
f.Close
Set f = Nothing
Set fs = Nothing
' Разбор строки для списка
Dim arCnn ' Массив строк
arCnn = Split(strCnn, vbCrLf, 5, vbBinaryCompare)
' Заполнение списка
Dim i As Long
Me.myList.RowSource = ""
For i = 0 To UBound(arCnn) - 1
Me.myList.RowSource = Me.myList.RowSource arCnn(i) ";"
Next i
End Sub
'==============================================================
' ADO. Создаем файл UDL
Private Sub butWrite_Click()
' Строка файла udl
Dim strUdl As String ' Файл
strUdl = Application.CurrentProject.Path "\la_ado1.udl"
' Открываем файл
Dim fs, f
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.CreateTextFile(strUdl, True, True) ' Файл, Переписать, Unicode
' Создаем строку для файла
' 2 строки информации, 3 для соединения (см. Пример 02)
'"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=D:\Access WebServer\subscribe\_mdb\la_array.mdb;Mode=Read|Write|Share Deny None;Persist Security Info=False;Jet OLEDB:Don't Copy Locale on Compact=True"
Dim strCnn As String
strCnn = "[oledb]" vbCrLf _
"; Everything after this line is an OLE DB initstring" vbCrLf _
"Provider=Microsoft.Jet.OLEDB.4.0;Mode=Read|Write|Share Deny None;Persist Security Info=False" vbCrLf
f.write strCnn
' Закрываем файл
f.Close
Set f = Nothing
Set fs = Nothing
MsgBox "Файл la_ado1.udl создан", vbExclamation, "Лидер Access"
End Sub
18. Если у Вас интерфейс хранится в одной базе, а данные в другой, то необходимо научится привязывать базу к таблицам на сервере. Иначе пользователю, используя стандартный интерфейс будет очень трудно это сделать. В этом примере показано как это делается автоматически через программный код.
Private Sub Form_Open(Cancel As Integer)
Dim s As String, tdf As TableDef, dbs As Database
Dim tdfName As String, dbsName As String, i As Integer
On Error GoTo 999
Set dbs = CurrentDb 'Выбор базы данных
dbs.Execute "DELETE * FROM [Пример 18]" 'Удаляем все записи
'Инициализация таймера загрузки
Application.SetOption "Строка состояния", True 'Показываем строку
i = 1: SysCmd acSysCmdInitMeter, "Загрузка таблиц ...", dbs.TableDefs.Count
For Each tdf In dbs.TableDefs 'Просматриваем все таблицы
SysCmd acSysCmdUpdateMeter, i: i = i + 1 'Перерисовываем таймер
dbsName = funGetSubString(tdf.Connect, ";DATABASE=", ";") 'Находим связанную таблицу
If (dbsName "") Then
tdfName = tdf.Name 'Имя таблицы
'Составляем запрос на добавление
s = "INSERT INTO [Пример 18] ( Вкл, Таблица, Файл ) SELECT " _
"False AS Вкл, """ _
tdfName """ AS Таблица,""" _
dbsName """ AS Файл;"
dbs.Execute s 'Добавляем в таблицу меню
End If
Next
SysCmd acSysCmdRemoveMeter 'Удаляем таймер
Me.Requery 'Изменяем запрос в форме
Exit Sub
999:
SysCmd acSysCmdRemoveMeter 'Удаляем таймер
MsgBox Err.Description 'Сообщаем об ошибке
Err.Clear
End Sub
14. Бывает при разработке интерфейса необходимо не только провести сортировку формы, но и сохранить текущую запись. Это делается с помощью этого кода
' Сортировка
Private Sub butSort_Click()
Dim frm As Form, rst As Recordset, myBook As String
On Error Resume Next
Set frm = [Form_Пример 14 пдч] 'Выбираем форму
myBook = frm.Книга
frm.OrderBy = "[Книга] asc" 'Сортируем по возрастанию
frm.OrderByOn = True 'Включаем сортировку
'Ищем запись
Set rst = frm.Recordset
rst.FindFirst "[Книга]='" myBook "'"
frm.Bookmark = rst.Bookmark 'Возвращаем позицию
Err.Clear
End Sub
'==============================================================
' Сортировка
Private Sub Form_Open(Cancel As Integer)
Dim frm As Form
Set frm = [Form_Пример 14 пдч] 'Выбираем форму
frm.OrderBy = "[Книга] desc" 'Сортируем по убыванию
frm.OrderByOn = True 'Включаем сортировку
End Sub
При разработке интерфейса Вам может потребоваться погасить или отобразить некоторую панель меню. Чтобы не копаться в справочниках и интернете этот пример поможет загрузить все меню в таблицу. Таким образом, вы будете знать все названия панелей ме��ю.
'==============================================================
' Загружаем все панели в запрос
Private Sub Form_Open(Cancel As Integer)
Dim cbr As CommandBar, s As String, dbs As Database
On Error GoTo 999
Set dbs = CurrentDb 'Выбор базы данных
dbs.Execute "DELETE * FROM [Пример 03]" 'Удаляем все записи
For Each cbr In Application.CommandBars 'Просматриваем все меню
If cbr.RowIndex = 0 Then 'Выбираем панели
'Составляем запрос на добавление
s = "INSERT INTO [Пример 03] ( Вкл, Имя, Перевод ) SELECT " _
cbr.Visible " AS Вкл, """ _
cbr.Name """ AS Имя,""" _
cbr.NameLocal """ AS Перевод;"
dbs.Execute s 'Добавляем в таблицу меню
End If
Next
Me.Requery 'Изменяем запрос
Exit Sub
999:
MsgBox Err.Description
Err.Clear
End Sub
'==============================================================
' Отображаем панель
Private Sub Вкл_Click()
If Me.Вкл = True Then
DoCmd.ShowToolbar Me.Перевод, acToolbarYes
Else
DoCmd.ShowToolbar Me.Перевод, acToolbarNo
End If
End Sub
06. Данный пример показывает как можно проверять текстовые документы в Access, используя Word. Дается 2 варианта - быстрый и медленный с вызовом диалога коррекции текста.
' Проверка текста с диалогом
Private Sub butExecute_Click()
Dim app As Word.Application 'Приложение программы
'Dim obj As Object 'Приложение программы, 2 вариант
On Error GoTo 999
' Нужна проверка на ввод текст
If Nz(Me.Text, "") = "" Then
MsgBox "Введите текст!"
Exit Sub
End If
' Сообщение о начале проверки
Me.Result = "Думаю ... Для замены фраз откройте Word"
DoEvents
Set app = New Word.Application
' Set app = CreateObject("Word.Application") ' 2 вариант
With app
' Отображаем Word
.Visible = True
' Добавляем документ для проверки
.Documents.Add
' Печатаем проверяемый текст
.Selection.TypeText Me.Text
' Настраиваем опции проверки
.Options.CheckGrammarWithSpelling = False
.Options.IgnoreUppercase = False
' Выполняем проверку
.ActiveDocument.CheckSpelling
' Выбираем новый для проверки текст
.Selection.WholeStory
' Копируем текст в буфер
.Selection.Copy
' Возвращаем результат после проверки
Me.Result = .Selection.Text
' Возвращаем текст из буфера
' Me.Result = Clipboard.GetText
' Закрываем Word
.ActiveDocument.Close (0)
.Quit
End With
' Закрываем приложение
Set app = Nothing
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
End Sub
' Быстрая проверка на наличие ошибок
Private Sub butExecute2_Click()
Dim app As Word.Application
'Dim obj As Object 'Приложение программы, 2 вариант
On Error GoTo 999
' Нужна проверка на ввод текст
If Nz(Me.Text, "") = "" Then
MsgBox "Введите текст!"
Exit Sub
End If
' Сообщение о начале проверки
Me.Result = "Думаю ..."
DoEvents
' Set app = CreateObject("Word.Application") ' 2 вариант
Set app = New Word.Application
' Быстрая проверка
If app.CheckSpelling(Me.Text) Then
Me.Result = "Проверка текста прошла успешно!"
Else
Me.Result = "В тексте есть ошибки"
End If
' Освобождаем память
app.Quit
Set app = Nothing
Exit Sub
999:
MsgBox Err.Description 'Ошибка
Err.Clear
End Sub
09. По умолчанию таблицы открываются в небольшом окне, для того чтобы их открыть на все окно используйте этот пример.
Private Sub butExecute_Click()
On Error GoTo 999
funOffBars 'Гасим все панели
DoCmd.ShowToolbar "Menu Bar", acToolbarYes 'Строка меню
DoCmd.ShowToolbar "Table Datasheet", acToolbarYes 'Меню таблиц
DoCmd.OpenTable "Пример 01", acViewNormal 'Открываем таблицу
DoCmd.Maximize 'Масштабирование
Exit Sub
999:
MsgBox Err.Description, vbCritical, "Масштабирование"
Err.Clear
End Sub