Программирование на Visual Basic

SELECT - это ключевая команда в запросах. С нее начинается построение источников данных для форм, отчетов. Изучите несколько простых примеров ее использования

-- Выборка без таблиц
SELECT "Ура!" as Афиша, "Вперед!" as Лозунг; 

-- Выборка всего
SELECT  * FROM [Данные];

-- Выборка из 1 поля всех записей
SELECT  ALL [Книга] FROM [Данные]; 

-- Замена имени таблицы
SELECT [T5].КурсUSD From [Данные] as [T5]; 

 -- Выборка 1 записи
SELECT TOP 1 * FROM [Данные];

-- 25 процентов данных
SELECT TOP 25 PERCENT * FROM [Данные] ORDER BY КурсUSD DESC; 

-- Уникальные книги
SELECT DISTINCT [Книга] FROM [Данные]; 

-- Выборка из уникальной таблицы
SELECT * FROM [Данные] WITH OWNERACCESS OPTION

Max - вычисляет в запросе максимальное значение в поле, Min - минимальное, Avg - среднее значение, Last - выбирает последню запись, Sum - суммирует данные.

-- Поиск максимального значения
SELECT Max(КурсUSD) as MaxUSD  From [Данные];

-- Выборка среднего значения
SELECT Avg(КурсUSD) as Средний  From [Данные];

-- Выборка минимального значения
SELECT Min(КурсUSD) as Минимальный  From [Данные];

-- Выборка первого значения
SELECT First(КурсUSD) as Первый From [Данные];

-- Выборка последнего значения
SELECT Last(КурсUSD) as Последний From [Данные];

-- Суммирование полей
SELECT Sum(СуммаРуб) as Сумма From [Данные];

-- Расчет количества
SELECT Count(КурсUSD) as Кол_во From [Данные];

02. Этот пример показывает как с использованием API интерфейса определить информацию по дискам системы.

' Запрашиваем информацию о диске
Private Declare Function apiGetDiskFreeSpace Lib "kernel32" Alias "GetDiskFreeSpaceA" _
    (ByVal lpRootPathName As String, _
        lpSectorsPerCluster As Long, _
        lpBytesPerSector As Long, _
        lpNumberOfFreeClusters As Long, _
        lpTotalNumberOfClusters As Long) As Long

'  Загрузка данных
Private Sub Form_Load()
    On Error Resume Next
    Me.myDrive.RowSource = funGetDrivers
    Me.myDrive = Me.myDrive.Column(0, 0)
    myDrive_AfterUpdate
    Err.Clear
End Sub

'  Получаем информацию о диске системы
Private Function funInformationDisk()
Dim fs, dc, D, s As String
On Error Resume Next
    s = ""
    ' 1. Получаем информацию из файловой системы
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each D In dc
        If StrComp(D.DriveLetter, Left(myDrive, 1), vbTextCompare) = 0 Then
            s = s  "Серийный номер: "  D.SerialNumber  ";"
            s = s  "Емкость диска: "  Format(D.TotalSize, "#,0")  ";"
            s = s  "Доступный объем диска: "  Format(D.AvailableSpace, "#,0")  ";"
            s = s  "Свободное место на диске: "  Format(D.FreeSpace, "#,0")  ";"
            s = s  "Метка тома: "  D.VolumeName  ";"
            s = s  "Файловая система: "  D.FileSystem  ";"
            Exit For
        End If
        Err.Clear
    Next D
    ' 2. Получаем информацию из api интерфейса
    Dim SectorsPerCluster As Long ' Секторов на клястер
    Dim BytesPerSector As Long ' Байт на сектор
    Dim NumberOfFreeClustors As Long ' Свободных клястеров
    Dim TotalNumberOfClustors As Long ' Всего клястеров

    ' Запрашиваем свободное место
    Call apiGetDiskFreeSpace(Left(Me.myDrive, 2), _
        SectorsPerCluster, BytesPerSector, _
        NumberOfFreeClustors, TotalNumberOfClustors)
    s = s  "Число секторов на клястер: "  Format(SectorsPerCluster, "#,0")  ";"
    s = s  "Число байт на сектор: "  Format(BytesPerSector, "#,0")  ";"
    s = s  "Число свободных клястеров: "  Format(NumberOfFreeClustors, "#,0")  ";"
    s = s  "Всего клястеров: "  Format(TotalNumberOfClustors, "#,0")  ";"
    
    ' Используя клястеры Вы можете определить
    ' a) Емкость диска = TotalNumberOfClustors * SectorsPerCluster * BytesPerSector
    ' b) Свободное место = NumberOfFreeClustors * SectorsPerCluster * BytesPerSector
    
    ' 3. Присваиваем источник данных
    Me.myList.RowSource = s
    Exit Function
End Function

'  Заполняем список с информацией о дисках
Private Function funGetDrivers() As String
Dim fs, dc, D
Dim s As String
On Error GoTo 999
    Err.Clear
    funGetDrivers = ""
    Set fs = CreateObject("Scripting.FileSystemObject")
    Set dc = fs.Drives
    For Each D In dc
        Select Case D.driveType
          Case 0: s = "Неизвестная БД"
          Case 1: s = "Дискета"
          Case 2: s = "Жесткий диск"
          Case 3: s = "Сетевой диск"
          Case 4: s = "CD-ROM"
          Case 5: s = "RAM диск"
        End Select
        If D.IsReady Then
           funGetDrivers = funGetDrivers  D.DriveLetter  ":\ - "  s  ";"
        End If
    Next
    Exit Function
999:
    MsgBox Err.Description
    Err.Clear
    funGetDrivers = ""
End Function

'  Обновляем информацию
Private Sub myDrive_AfterUpdate()
    funInformationDisk
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

01. Есть таблица, в ней нужно провести поиск по нескольким полям. При этом одно поле зависит от другого. Как это сделать указано в это примере.

'==============================================================
' Поиск по дате
Private Sub Дата_AfterUpdate()
Dim rst As Recordset, frm As Form
    On Error GoTo 999
    Set frm = Me.формаПоиск.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    rst.FindFirst "([Дата]=#"  Format(Me.Дата, "mm\/dd\/yyyy")  "#)"
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
        Me.Книга = rst!Книга
    Else
        MsgBox "Нет данных!"
    End If
    
    Exit Sub
999:
    MsgBox Err.Description  vbNewLine  "Введите правильно данные?"
End Sub

'==============================================================
' Начать поиск после обновления
Private Sub Книга_AfterUpdate()
    recordFind
End Sub

'==============================================================
' Поиск по дате и книге
Private Sub recordFind()
Dim rst As Recordset, frm As Form, s As String
    On Error GoTo 999
    Set frm = Me.формаПоиск.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    s = "([Дата]=#"  Format(Me.Дата, "mm\/dd\/yyyy")  _
                  "#) and (Книга='"  Me.Книга  "')"
    rst.FindFirst s
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
    Else
        MsgBox "Нет данных!"
    End If
    
    Exit Sub
999:
    MsgBox "Введите правильно данные?"
End Sub

'==============================================================
' Поиск по шаблону
Private Sub Шаблон_AfterUpdate()
Dim rst As Recordset, frm As Form, s As String
    On Error GoTo 999
    Set frm = Me.формаПоиск.Form 'Выбираем форму
    Set rst = frm.RecordsetClone 'Выбираем таблицу
    
    rst.FindFirst "([Книга] Like '"  Me.Шаблон  "')=True"
    If rst.NoMatch = False Then
        frm.Bookmark = rst.Bookmark
    Else
        MsgBox "Нет данных!"
    End If
    Exit Sub
999:
    MsgBox "Введите правильно данные?"
End Sub

'==============================================================
' Запрос по книге
Private Sub Книга_Enter()
    Me.Книга.RowSource = "SELECT Книга FROM [1-Мои книги] WHERE (((Дата)=[Forms]![Example 01]![Дата]));"
    'Me.Книга.Requery  'Изменить запрос
End Sub

01. В этом примере используется подключение к dbf файлу. Истользуйте пример для загрузки в Access таблиц dbf

Option Compare Database
Option Explicit

'==============================================================
'   Связь с таблицами
'       Для текущей базы данных
'   Предупреждение.
'       Если текстовые поля имеют неправильное отображение,
'       то установите в Access другую кодировку символов
Private Sub butLink_Click()
Dim myFile As String, s As String
    On Error GoTo 999
    Select Case Me.grTables
    Case 1:
        'Данный пример показывает как связать текущую Access
        'базу данных с таблицей dBase III: "la_table.dbf"
        'с имененем таблицы в Access dbf-таблица
        myFile = Application.CurrentProject.Path 'Каталог базы
        If Dir(Me.nameFileDbf.Caption)  "" Then 'Проверка файла
            DoCmd.TransferDatabase acLink, "dBase III", myFile, _
                acTable, "la_table.dbf", "dbf-таблица"
            'Изменяем вид кнопок формы
            setControl True
        Else
            MsgBox "Нет файла: "  Me.nameFileDbf.Caption
        End If
    End Select
    Exit Sub
999:
    'Ошибка может быть если dbf-файл находится в каталоге с русским именем
    MsgBox "Ошибка связи с таблицей", vbCritical, "Внешние связи"
    Err.Clear
    'Изменяем свойства элементов формы
    setControl False
End Sub

'==============================================================
'   Открытие формы
Private Sub Form_Open(Cancel As Integer)
Dim s As String
    s = Application.CurrentProject.Path 'Каталог базы
    Me.nameFileDbf.Caption = s  "\"  "la_table.dbf" 'Название файла
    butDelLink_Click
End Sub

'==============================================================
'   Удаление связи с таблицами
Private Sub butDelLink_Click()
    On Error Resume Next
    DoCmd.DeleteObject acTable, "dbf-таблица" 'Удаляем связь
    'Изменяем свойства элементов формы
    setControl False
End Sub

'==============================================================
'   Установка элементов формы
Private Sub setControl(myEnabled As Boolean)
    Me.grTables.SetFocus 'Меняем фокус
    If myEnabled = False Then
        Me.nameFileDbf.HyperlinkSubAddress = "" 'Меняем адрес
        Me.butLink.Enabled = True 'Меняем вид кнопки
        Me.butDelLink.Enabled = False 'Меняем вид кнопки
    Else
        Me.nameFileDbf.HyperlinkSubAddress = "Table dbf-таблица"
        Me.butLink.Enabled = False 'Меняем вид кнопки
        Me.butDelLink.Enabled = True 'Меняем вид кнопки
    End If
End Sub

01. Используя эту функцию, Вы можете загрузить разные курсоры в окно формы Access. Кусоры меняют форму когда вы управляете мышкой.

' Константы из API интерфейса
Const IDC_ARROW = 32512 'Стрелка
Const IDC_IBEAM = 32513 'Тип - I
Const IDC_WAIT = 32514 'Часы
Const IDC_CROSS = 32515 'Перекрестие
Const IDC_UPARROW = 32516 'Верх
Const IDC_SIZE = 32640 'Размер
Const IDC_ICON = 32641
Const IDC_SIZENWSE = 32642 'Стрелки размеров
Const IDC_SIZENESW = 32643
Const IDC_SIZEWE = 32644
Const IDC_SIZENS = 32645
Const IDC_SIZEALL = 32646
Const IDC_NO = 32648 'Стоп курсор
Const IDC_APPSTARTING = 32650 'Стрелка и часы
Const IDC_HAND = 32649

' Загружает курсор из ресурса
Private Declare Function apiLoadCursorBynum Lib "user32" Alias "LoadCursorA" _
    (ByVal hInstance As Long, _
    ByVal lpCursorName As Long) _
    As Long

' Устанавливает курсор
Private Declare Function apiSetCursor Lib "user32" Alias "SetCursor" _
    (ByVal hCursor As Long) _
    As Long

' Загружает курсор из файла
Private Declare Function apiLoadCursorFromFile Lib "user32" Alias "LoadCursorFromFileA" _
    (ByVal lpFileName As String) _
    As Long

'Указатель на курсор
Dim hCursor As Long

'==============================================================
'  Назначение
'    Загружаем курсор
Private Sub Объекты_AfterUpdate()
    On Error GoTo 999
    Select Case Me.Объекты
        Case 1: 'Указатель
            hCursor = apiLoadCursorBynum(0, IDC_ARROW)
        Case 2: 'Редактор
            hCursor = apiLoadCursorBynum(0, IDC_IBEAM)
        Case 3: 'Часы
            hCursor = apiLoadCursorBynum(0, IDC_WAIT)
        Case 4 'Перекрестие
            hCursor = apiLoadCursorBynum(0, IDC_CROSS)
        Case 5: 'Стрелка вверх
            hCursor = apiLoadCursorBynum(0, IDC_UPARROW)
        Case 6: 'Размер
            hCursor = apiLoadCursorBynum(0, IDC_SIZE)
        Case 7: 'Иконка
            hCursor = apiLoadCursorBynum(0, IDC_ICON)
        Case 8: 'Стрелка
            hCursor = apiLoadCursorBynum(0, IDC_SIZENWSE)
        Case 9 'Стрелка
            hCursor = apiLoadCursorBynum(0, IDC_SIZENESW)
        Case 10 'Стрелка
            hCursor = apiLoadCursorBynum(0, IDC_SIZEWE)
        Case 11 'Стрелка
            hCursor = apiLoadCursorBynum(0, IDC_SIZENS)
        Case 12 'Стрелка
            hCursor = apiLoadCursorBynum(0, IDC_SIZEALL)
        Case 13 'Стоп курсор
            hCursor = apiLoadCursorBynum(0, IDC_NO)
        Case 14 'Старт приложения
            hCursor = apiLoadCursorBynum(0, IDC_APPSTARTING)
        Case 15 'Загрузить из файла
            hCursor = apiLoadCursorFromFile( _
            Application.CurrentProject.Path  _
            "\la_api.cur")
        Case 16 'Рука курсор
            hCursor = apiLoadCursorBynum(0, IDC_HAND)
    End Select
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
End Sub

'  Изменяем курсор
Private Sub Пример_01_MouseMove(Button As Integer, Shift As Integer, x As Single, Y As Single)
   Call apiSetCursor(hCursor)
End Sub

03. Этот пример показывает как с использованием API интерфейса определить информацию по Windows, номер версии, платформы и т.п.

' Структура с информацией о версии Windows
Private Type OSVERSIONINFO
        dwOSVersionInfoSize As Long
        dwMajorVersion As Long
        dwMinorVersion As Long
        dwBuildNumber As Long
        dwPlatformId As Long
        szCSDVersion As String * 128
End Type

' Api константы платформы Windows
Const VER_PLATFORM_WIN32s = 0
Const VER_PLATFORM_WIN32_WINDOWS = 1
Const VER_PLATFORM_WIN32_NT = 2

' Получаем информацию о версии
Private Declare Function apiGetVersionEx Lib "kernel32" Alias "GetVersionExA" _
    (lpVersionInformation As OSVERSIONINFO) As Long

'  Загрузка данных
Private Sub Form_Load()
Dim myVer As OSVERSIONINFO
Dim s As String

        ' Инициализируем строку
        s = ""
        ' Определяем размер структуры
        myVer.dwOSVersionInfoSize = 148
        
        ' Получаем информацию о версии
        Call apiGetVersionEx(myVer)
        If myVer.dwPlatformId = VER_PLATFORM_WIN32_WINDOWS Then
            s = s  "Платформа: Windows 95;"
        ElseIf myVer.dwPlatformId = VER_PLATFORM_WIN32_NT Then
            s = s  "Платформа: Windows NT;"
        End If
        s = s  "Версия: "  myVer.dwMajorVersion  "."  myVer.dwMinorVersion  ";"
        s = s  "Построение: "  (myVer.dwBuildNumber And HFFFF)  ";"
        
        ' Устанавливаем список
        Me.myList.RowSource = s
End Sub

01. Dictionary - этот объект можно использовать для создания массивов, даже для форм. Таким образом можно создать интерфейс, который будет открывать 2 одинаковые формы, что в Access нереально создать обычным способом.

'==============================================================
'   Использование массива Dictionary для таблицы
Public Function funArrayDictionary() As String
Dim s As String, i  As Integer, dbs As Database, rst As Recordset
Dim myArray, myBooks 'Переменные для массива
   
    On Error GoTo 999 'Обработка ошибки

'1.Открытие таблицы
    Set dbs = CurrentDb 'Выбираем базу данных
    Set rst = dbs.OpenRecordset("SELECT * FROM [Мои книги]") 'Создаем запрос
    If (rst.RecordCount = 0) Then 'Проверяем таблицу
        rst.Close 'Закрываем запрос
        MsgBox "Нет данных" 'Сообщаем об этом
        Exit Function
    End If

'2. Заполнение запроса
    rst.MoveLast
    rst.MoveFirst
    
'3. Заполнение массива
    Set myArray = CreateObject("Scripting.Dictionary") 'Создаем массив
    myArray.RemoveAll 'Удаляем все
    For i = 0 To rst.RecordCount - 1
          myArray.Add CStr(rst!Ключ), CStr(rst!Книга) 'Добавляем значение в массив
          rst.MoveNext 'переходим на следующую запись
    Next i

'4. Проверка массива
    myBooks = myArray.Items        'Выбираем все книги
    For i = 0 To myArray.Count - 1 'Создаем цикл
        s = s  myBooks(i)  vbCrLf  'Создаем список книг
    Next
    funArrayDictionary = s 'Возвращаем список

'5. Конец примера
    myArray.RemoveAll 'Удаляем массив
    rst.Close
    Set dbs = Nothing '!Внимание. Посылаем ... переменную!
    Exit Function
999:
    MsgBox Err.Description
    Err.Clear
    rst.Close
End Function

Использование Application.FileSearch поможет Вам найти файлы на диске. Для Office 2007 эта функция не работает. Можно использовать другие функции, типа Dir, FileSystemObject и т.п.

' Поиск файлов по шаблону
Private Sub butRead_Click()
Dim i As Long
On Error GoTo 999
    With Application.FileSearch
       .NewSearch
       .LookIn = Me.myFolder ' = c:\
       .FILENAME = Me.myExt ' = *.mdb
       .SearchSubFolders = Me.myFflagSubFolder ' = True
       If .Execute(SortBy:=msoSortByFileName, _
                SortOrder:=msoSortOrderAscending)  0 Then
            Me.progress = "Count="  .FoundFiles.Count  vbCrLf
            For i = 1 To .FoundFiles.Count
                Me.progress = Me.progress  .FoundFiles(i)  vbCrLf
            Next i
       End If
    End With
    Exit Sub      'Выходим из программы
999:
    MsgBox Err.Description
    Err.Clear 'Очищаем поток от ошибок
End Sub