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

03. Данный пример показывает как можно быстро создать документ Word из Microsoft Access, используя шаблон *.dot. Для разметки документа используются специальные закладки.

'==============================================================
'   Создание документа Word по шаблону
'   • Для этого Вы должны создать в Word шаблон la_automat.dot
'   и поставить в нем Закладки, имеющие такие же имена как в форме.
'   Например, Вставка - Закладка ... - Имя закладки=Фирма
'   (Нажмите кнопку Добавить и сохраните шаблон)
'
Private Sub butNewWord_Click()
Dim app As Word.Application  'Приложение программы
Dim strDOC As String ' Имя документа
Dim strDOT As String ' Имя шаблона
Dim ctl As Control ' Управляющие элементы в форме
Dim s As String ' Вспомогательная строка
    
    On Error GoTo 999
    ' Определяем имена шаблона и документа Word
    With Application.CurrentProject
        strDOT = .Path  "\"  "la_automat.dot"
        strDOC = .Path  "\"  "la_automat.doc"
    End With
    
    ' Управление документом Word
    Set app = New Word.Application 'Новое приложение Word
    app.Visible = True 'Отображаем документ
    app.Documents.Add strDOT 'Добавляем шаблон
    With app.ActiveDocument  'Выбираем активный документ
        On Error Resume Next ' Отключаем ошибки
        ' Просматриваем все элементы формы, если
        ' такой закладки нет, то очищаем поток от ошибки
        For Each ctl In Me.Controls
            If ctl.ControlType = acTextBox Then
                s = ctl.Name ' Определяем название элемента
                .Bookmarks.Item(s).Range.Text = Me(s) 'Устанавливаем текст
                Err.Clear ' Очищаем поток от ошибки при отсутствии элемента
            End If
        Next ctl
        .SaveAs strDOC ' Сохраняем файл
        On Error GoTo 999 ' Включаем обработку ошибки
    End With
    ' app.Quit 'Закрываем приложение
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
    app.Quit
End Sub

Для быстрого запуска приложения из Access можно воспользоваться командой shell. Она позволяет запускать любые программы: notepad.exe, explorer.exe и т.п.

Private Declare Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
    (ByVal hwnd As Long, _
     ByVal lpOperation As String, _
     ByVal lpFile As String, _
     ByVal lpParameters As String, _
     ByVal lpDirectory As String, _
     ByVal nShowCmd As Long) _
As Long

Private Sub butOpenFolder_Click()
        Shell "explorer.exe ""C:\""", vbNormalFocus
End Sub

Private Sub butSelectFile_Click()
    ' Включите библитеку libDialogFiles
    Me.strFilePath = fOfficeGetFile("Выберите файл", "C:", "*.txt")
End Sub

Private Sub strFilePath_DblClick(Cancel As Integer)
On Error GoTo 999
'    If Me.Var = 1 Then
        Dim StartDoc As Long
        Dim SW_SHOWNORMAL As Long
        If Not IsNull(Me.strFilePath) Then
            StartDoc = ShellExecute(Me.hwnd, "", Me.strFilePath, _
                "", "", SW_SHOWNORMAL)
        End If
'    End If
    
    Exit Sub

999:
   MsgBox "Error: "  Err  " "  Error
   Exit Sub

End Sub

16. Этот код очень часто используется при разработке бухгалтерских систем, где требуется не только написать сумму, но и вывести ее прописью. Инструкция центробанка требует еще и разделение цифр не точкой, а дефисом -.

Const SPACE As String = " " 'Определяет число пробелов между словами

'==============================================================
' Назначение:
'    Перевод числа в строковую константу
' Параметры
'    curMoney - сумма, которую надо перевести в строку
'    flagBank - указывает какую сумму надо вернуть
' Пример:
'    funRusMoney(678.56) = "Шестьсот семьдесят восемь рублей 56 копеек"
'
Public Function funRusMoney(curMoney As Currency, flagBank) As String
Dim myMoney As Currency 'Все деньги
Dim myRoubles As Long 'Только рубли
Dim myCopecks As Long 'Только копейки
Dim iGroup As Long 'Группировка по разрядам
Dim s As String 'Промежуточная переменная
    
    On Error GoTo 999
    'Проведем округление абслютного результата до 2х разрядов.
    'Иногда бывает в функцию передается результат: -678,56001,
    'а нам нужен 678,56
    myMoney = Format(Abs(curMoney), "0.00")
    
    'Проверка входящей суммы
    If myMoney  2147483647.99 Then
        MsgBox "Очень большое число: "  Format(curMoney, "Currency")  vbCrLf  _
               "Максимальное число: 2 147 483 647,99", vbExclamation, "Сумма прописью"
               funRusMoney = "Слишком большое число: "  curMoney
        Exit Function
    End If
    
    'Определяем рубли и копейки
    myRoubles = CLng(Fix(myMoney))
    myCopecks = (myMoney - Fix(myMoney)) * 100
    
    If myRoubles  0 Then 'Есть рубли
        'Миллиарды рублей
        s = funTextMoney(myRoubles, myCopecks, 1000000000, "М", iGroup)
        'Миллионы рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1000000, "М", iGroup)
        'Тысячи рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1000, "Ж", iGroup)
        'Cотни рублей
        s = s  funTextMoney(myRoubles, myCopecks, 1, "М", iGroup)
        'Дописываем рубли
        s = s  strRoubles(iGroup)
    Else 'Нет рублей
        s = "0 рублей"  SPACE
    End If
    'Добавляем копейки прописью
    If (flagBank = True) And (myCopecks = 0) Then
        'не добавляем копеек по инструкции Центробанка
    Else
        s = s  strCopecks(myCopecks) 'Дописываем копейки
    End If
    
    'Вывод текста c Заглавной буквы
    funRusMoney = UCase(Mid(s, 1, 1))  Mid(s, 2)
    Exit Function
999:
    MsgBox Err.Description, vbCritical, "Сумма прописью"
    funRusMoney = "Ошибка в прописи суммы: "  curMoney
    Err.Clear
End Function

'==============================================================
' Назначение:
'    Перевод для разных групп чисел в строковую константу
' Параметры
'    myRoubles - рубли
'    myCopecks - копейки
'    iSize - размер группы (1, 1000, ...)
'    sSex - пол группы (М - мужской, Ж - женский)
' Пример:
'    funTextMoney(678,25,1,"М") = _
'                "шестьсот семьдесят восемь рублей 25 копеек"
'
Public Function funTextMoney( _
    myRoubles As Long, _
    myCopecks As Long, _
    iSize As Long, _
    sSex As String, _
    iGroup As Long _
    ) As String

Dim iBlock As Long 'Блок данных
Dim sOut As String 'Выходная строка

    sOut = "" 'Инициализация переменной
    iGroup = myRoubles \ iSize 'Возвращем число 0-999
    If (iGroup  0) Then
        iBlock = iGroup \ 100 'Вернуть сотни
        sOut = sOut  strHundreds(iBlock) 'Вернуть текст
        myRoubles = myRoubles - iBlock * 100 * iSize 'Оставшаяся сумма
        
        iGroup = iGroup - iBlock * 100 'Возвращем число 0-99
        If iGroup  19 Then
            iBlock = iGroup \ 10 'Вернуть десятки
            sOut = sOut  strTens(iBlock) 'Вернуть текст
            myRoubles = myRoubles - iBlock * 10 * iSize 'Оставшаяся сумма
            iGroup = iGroup - iBlock * 10 'Возвращем число 0-9
        End If

        sOut = sOut  strOne(iGroup, sSex) 'Вернуть текст
        myRoubles = myRoubles - iGroup * iSize  'Оставшаяся сумма
        
        'Добавляем текст в конец строки
        Select Case iSize
            Case 1000000000: sOut = sOut  strBillions(iGroup)
            Case 1000000: sOut = sOut  strMillions(iGroup)
            Case 1000: sOut = sOut  strThousand(iGroup)
        End Select
    End If
    
    'Возвращаем текст
    funTextMoney = sOut
End Function

'==============================================================
' Назначение:
'       вернуть миллиарды прописью
' Пример:
'       strBillions(2) = "миллиард"
'
Function strBillions(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strBillions = "миллиард"
        Case 2 To 4: strBillions = "милиарда"
        Case Else:   strBillions = "миллиардов"
    End Select
    strBillions = strBillions  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть миллионы прописью
' Пример:
'       strMillions(2) = "миллиона"
'
Public Function strMillions(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strMillions = "миллион"
        Case 2 To 4: strMillions = "миллиона"
        Case Else:   strMillions = "миллионов"
    End Select
    strMillions = strMillions  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть тысячи прописью
' Пример:
'       strThousand(2) = "тысячи"
'
Public Function strThousand(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strThousand = "тысяча"
        Case 2 To 4: strThousand = "тысячи"
        Case Else:   strThousand = "тысяч"
    End Select
    strThousand = strThousand  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть сотни прописью
' Пример:
'       strHundreds(2)="двести"
'
Public Function strHundreds(iBlock As Long) As String
    Select Case iBlock
         Case 1:  strHundreds = "сто"
         Case 2:  strHundreds = "двести"
         Case 3:  strHundreds = "триста"
         Case 4:  strHundreds = "четыреста"
         Case 5:  strHundreds = "пятьсот"
         Case 6:  strHundreds = "шестьсот"
         Case 7:  strHundreds = "семьсот"
         Case 8:  strHundreds = "восемьсот"
         Case 9:  strHundreds = "девятьсот"
    End Select
    If iBlock  0 Then strHundreds = strHundreds  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть десятки прописью
' Пример:
'       strTens(3) = "тридцать"
'
Public Function strTens(iBlock As Long) As String
    Select Case iBlock
         Case 2: strTens = "двадцать"
         Case 3: strTens = "тридцать "
         Case 4: strTens = "сорок"
         Case 5: strTens = "пятьдесят"
         Case 6: strTens = "шестьдесят"
         Case 7: strTens = "семьдесят"
         Case 8: strTens = "восемьдесят"
         Case 9: strTens = "девяносто"
    End Select
    If iBlock  0 Then strTens = strTens  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть единицы прописью
' Пример:
'       strOne(2, "М")="два"
Public Function strOne(iBlock As Long, sSex As String) As String
    Select Case iBlock
        Case 1, 2
            Select Case iBlock  sSex 'Определяем пол
            Case "1М": strOne = "один" 'Мужской пол
            Case "2М": strOne = "два" 'Мужской пол
            Case "1Ж": strOne = "одна" 'Женский пол
            Case "2Ж": strOne = "две" 'Женский пол
            End Select
        Case 3:   strOne = "три"
        Case 4:   strOne = "четыре"
        Case 5:   strOne = "пять"
        Case 6:   strOne = "шесть"
        Case 7:   strOne = "семь"
        Case 8:   strOne = "восемь"
        Case 9:   strOne = "девять"
        Case 10:  strOne = "десять"
        Case 11:  strOne = "одиннадцать"
        Case 12:  strOne = "двенадцать"
        Case 13:  strOne = "тринадцать"
        Case 14:  strOne = "четырнадцать"
        Case 15:  strOne = "пятнадцать"
        Case 16:  strOne = "шестнадцать"
        Case 17:  strOne = "семнадцать"
        Case 18:  strOne = "восемнадцать"
        Case 19:  strOne = "девятнадцать"
    End Select
    If iBlock  0 Then strOne = strOne  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть копейки прописью
' Пример:
'       strCopecks(56) = "56 копеек"
'
Public Function strCopecks(myCopecks As Long) As String
Dim r As Integer 'разряд копеек
    'Записываем копейки
    strCopecks = Format(myCopecks, "00")  SPACE
    
    'Определяем разряд копеек
    r = myCopecks
    If myCopecks  20 Then r = r - Fix(r / 10) * 10
    Select Case r 'Составляем текст
        Case 1:      strCopecks = strCopecks  "копейка"
        Case 2 To 4: strCopecks = strCopecks  "копейки"
        Case Else:   strCopecks = strCopecks  "копеек"
    End Select
End Function

'==============================================================
' Назначение:
'       вернуть название рублей прописью
' Пример:
'       strRoubles(2) = "рубля"
'
Public Function strRoubles(iBlock As Long) As String
    Select Case iBlock
        Case 1:      strRoubles = "рубль"
        Case 2 To 4: strRoubles = "рубля"
        Case Else:   strRoubles = "рублей"
    End Select
    strRoubles = strRoubles  SPACE
End Function

'==============================================================
' Назначение:
'       вернуть сумму по инструкции центробанка
'
Public Function strConvBank(curMoney As Currency) As String
Dim myCopecks As Long
'    strConvBank = Format(curMoney, "0") 'Формат рублей
    myCopecks = (curMoney - Fix(curMoney)) * 100
    strConvBank = CStr(curMoney - myCopecks / 100)
    If myCopecks = 0 Then
        strConvBank = strConvBank  "=" 'Без копеек
    Else
        strConvBank = strConvBank  "-"  Format(myCopecks, "00") 'С копейками
    End If
End Function

19. Таблицу в подчиненной форме невозможно раскрасить простым способом, для этого надо знать некоторые хитрости. Посмотрите этот пример.

Private Sub Form_Open(Cancel As Integer)
On Error Resume Next
    'Назначаем цвет для всей таблицы
    Me.DatasheetBackColor = RGB(180, 210, 180)
    
    'Назначим в поле 'Дата' такое форматирование, чтобы
    'выделить дату = 20 сентября 2000 года
    With Me.Дата
        .FormatConditions.Delete 'Удаляем все условия
        'Назначение форматирования
        .FormatConditions.Add acFieldValue, acEqual, "#09/20/2000#"
        'Изменение цвета ячейки
        With .FormatConditions(0)
           .BackColor = 13434828 'Цвет фона
           .FontBold = True 'Толщина букв
           .ForeColor = RGB(255, 0, 0) 'Цвет символов - красный
        End With
    End With
    'Назначим в поле 'Книга' такое форматирование, при котором
    'будут отображаться строки с полем Сумма  30 рублей
    With Me.Книга
        .FormatConditions.Delete 'Удаляем все условия
        .FormatConditions.Add acExpression, , "[Сумма]30" 'выражение
        .FormatConditions(0).BackColor = 12632256 'Серый цвет фона
    End With
    
    'Назначим в поле 'Сумма' такое форматирование, при котором
    'при входе в поле будет меняться цвет символов
    With Me.Сумма
        .FormatConditions.Delete 'Удаляем все условия
        .FormatConditions.Add acFieldHasFocus 'Назначаем фокус
        .FormatConditions(0).ForeColor = RGB(0, 0, 255) 'Синий цвет
        .FormatConditions.Add acFieldValue, acBetween, "200", "500"
        .FormatConditions(1).ForeColor = 255
    End With
    Err.Clear
End Sub

Этот пример покажет Вам как управлять бинарными файлами из Access, метод нужен для обращения к файлам отличным от Access

'==============================================================
' Создаем бинарный файл
Private Sub butWrite_Click()
Dim intFile As Integer
Dim myRec As AppRecord
    
    
'    Open Me.strPath For Binary Access Write As #intFile
'    Open Me.strPath For Random As #intFile Len = Len(myRec)
    intFile = FreeFile()
    Open Me.strPath For Binary As #intFile
    With myRec ' Создание записи
        .ID = 125
        .Name1 = "Мой телефон"
        .Phone1 = 92345678
        .Date1 = Date
    End With
    Put #intFile, 1, myRec ' Сохранение в файле
    ' Закрываем файл
    Close #intFile
    ' Отображение кнопки
    Form_Load
    ' Сообщение
    MsgBox "Бинарный файл "  Me.strPath  " создан!", vbExclamation, "www.leadersoft.ru"
End Sub

При разработке интерфейса Вам может потребоваться погасить или отобразить меню. Этот пример показывает, как можно это сделать.

Private Sub butProgram1_Click()
    Me.MenuBar = "Мое меню"
    If Me.butProgram1.Caption = "Отобразить меню" Then
        DoCmd.ShowToolbar Me.MenuBar, acToolbarYes
        Me.butProgram1.Caption = "Погасить меню"
    Else
        DoCmd.ShowToolbar Me.MenuBar, acToolbarNo
        Me.butProgram1.Caption = "Отобразить меню"
    End If
End Sub

04. Пример показывает Вам как определить разрешение экрана окна формы.

Private Declare Function apiGetSystemMetrics Lib "user32" Alias "GetSystemMetrics" _
 (ByVal nIndex As Long) As Long

'==============================================================
'   Получить разрешение экрана
Private Sub кнОткрыть_Click()
    Me.myMemo.Caption = "Разрешение по X: "  _
                apiGetSystemMetrics(0)  vbCrLf
    Me.myMemo.Caption = Me.myMemo.Caption  _
                        "Разрешение по Y: "  _
                apiGetSystemMetrics(1)
End Sub

Данный пример показывает, как можно хранить в базе данных информацию по музыке, а в случае ее необходимости проиграть. Проигрыватель сделан в виде эллипса, используя этот метод можно создать его любой формы (..\04 Интерфейс\Музыка\la_mp3_player.mdb).

Private Sub Form_Load()
Dim hRgn As Long    'Область окна
Dim x0 As Long, y0 As Long, ww As Long, hh As Long
Dim scrX As Long 'Коэффициент перевода в пикселы
Dim scrY As Long 'Коэффициент перевода в пикселы
Dim frmhwnd As Long, frmhdc As Long
    
    ' Очистить сообщения
    DoEvents
    
    ' Определяем размеры окна и область отсечения
    frmhwnd = apiFindWindowEx(Me.hWnd, apiFindWindowEx(Me.hWnd, 0, "OFormSub", ""), "OFormSub", "")
    If frmhwnd = 0 Then Exit Sub
    
    ' Определяем контекст устройства
    frmhdc = apiGetDC(frmhwnd)
    
    'Определяем размеры области отсечения
    'Число твипов в пикселах
    scrX = 1440 / apiGetDeviceCaps(frmhdc, LOGPIXELSX)
    scrY = 1440 / apiGetDeviceCaps(frmhdc, LOGPIXELSY)
    With Me.Controls("myPicture")
        x0 = .Left / scrX '+ 1 'Позиция в пикселах
        y0 = .Top / scrY '+ 1 'Позиция в пикселах
        ww = .Width / scrX - 1 'Ширина таймера
        hh = .Height / scrY - 1 'Высота таймера
    End With
    Call apiReleaseDC(frmhwnd, frmhdc)
    hRgn = apiCreateEllipticRgn(x0, y0, ww, hh) 'Область отсечения
    
    'Отрезаем лишнее от окна
    If hRgn  0 Then
       Call apiSetWindowRgn(Me.hWnd, hRgn, True)
    End If
    
End Sub

' leadersoft.ru - v01 от 02.03.2001
Private Sub Form_Open(Cancel As Integer)
    ' При открытии запускаем проигрыватель
    nFileName = Application.CurrentProject.Path  "\Flaming Star.mp3"
    If Dir(nFileName, vbNormal)  "" Then
        Me.butExit.SetFocus
        Me.butSelect.Enabled = False
        MP3Play Me.hWnd, nFileName
    End If
End Sub

' Определяем режим движения окна
' leadersoft.ru - v01 от 02.03.2001
Private Sub myPicture_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    apiReleaseCapture 'Эмуляция захвата окна
    Call apiSendMessage(Me.hWnd, WM_SYSCOMMAND, SC_MOVE_MOUSE, 0)
End Sub

'Это просто остановка программы
Private Sub butVBA_Click()
    Stop
End Sub

'
' Сайт: http://www.vbforums.com/archive/index.php/t-272432.html
'
Public Function MP3Play(wndHandle As Long, sFileName As String)
Dim cmdToDo As String * 255
Dim dwReturn As Long
Dim ret As String * 128
Dim tmp As String * 255
Dim lenShort As Long
Dim ShortPathAndFie As String, glo_HWND As Long

    If Dir(sFileName) = "" Then
        mmOpen = "Error with input file"
        Exit Function
    End If
    lenShort = GetShortPathName(sFileName, tmp, 255)
    ShortPathAndFie = Left$(tmp, lenShort)
    glo_HWND = wndHandle
    cmdToDo = "open "  ShortPathAndFie  " type MPEGVideo Alias MP3Play"
    dwReturn = mciSendString(cmdToDo, 0, 0, 0)
    If dwReturn  0 Then 'not success
        mciGetErrorString dwReturn, ret, 128
        mmOpen = ret
        MsgBox ret, vbCritical
        Exit Function
    End If
    mmOpen = "Success"
    mciSendString "play MP3Play", 0, 0, 0
End Function

Public Function MP3Pause()
    mciSendString "pause MP3Play", 0, 0, 0
End Function

Public Function MP3UnPause()
    mciSendString "play MP3Play", 0, 0, 0
End Function

Public Function MP3Stop() As String
    mciSendString "stop MP3Play", 0, 0, 0
    mciSendString "close MP3Play", 0, 0, 0
End Function


Private Sub butExit_Click()
    DoCmd.Close acForm, Me.Form.Name
End Sub

Private Sub butSelect_Click()
    Me.butExit.SetFocus
    butSelect.Enabled = False
'    butExit.Enabled = False
    Open_file
End Sub

Private Sub butPause_Click()
    Me.butExit.SetFocus
    If butPause.Caption = "Пауза" Then
        butPause.Caption = "Играть "
        MP3Pause
    Else
        butPause.Caption = "Пауза"
        MP3UnPause
    End If
End Sub

Private Sub butStop_Click()
    Me.butExit.SetFocus
    butPause.Enabled = False
    butStop.Enabled = False
    butStart.Enabled = False
    butSelect.Enabled = True
    butPause.Caption = "Пауза"
    MP3Stop
End Sub

Private Sub butStart_Click()
    Me.butExit.SetFocus
    mciSendString "stop MP3Play", 0, 0, 0
    mciSendString "play MP3Play from 0", 0, 0, 0
    butPause.Caption = "Пауза"
End Sub

' Срабатывает, когда заканчивается музыка
Private Sub Form_Timer()
    If IsPlaying = False And butSelect.Enabled = False And butPause.Caption = "Пауза" Then
        butStop_Click
    End If
End Sub

Private Sub Form_Unload(Cancel As Integer)
    MP3Stop
End Sub

Private Sub Open_file()
Dim cderr As Long
    OFN.lStructSize = 76
    OFN.hwndOwner = Me.hWnd
    OFN.lpstrFilter = "mp3 (*.mp3)" + Chr(0) + "*.mp3" + Chr(0) + Chr(0)
    OFN.lpstrCustomFilter = String(256, Chr(0))
    OFN.nMaxCustFilter = 256
    OFN.lpstrFile = "" + String(512, Chr(0))
    OFN.nMaxFile = 512
    OFN.lpstrFileTitle = String(256, Chr(0))
    OFN.nMaxFileTitle = 256
    OFN.flags = OFN_FILEMUSTEXIST + OFN_HIDEREADONLY
    '************
    DoEvents
    '************
    If GetOpenFileName(OFN) Then
        OFN.lpstrFile = Mid(OFN.lpstrFile, 1, InStr(OFN.lpstrFile, Chr(0)) - 1)
        nFileName = OFN.lpstrFile
        OFN.lpstrFileTitle = Mid(OFN.lpstrFileTitle, 1, InStr(OFN.lpstrFileTitle, Chr(0)) - 1)
        InitialDir = Left(OFN.lpstrFile, Len(OFN.lpstrFile) - Len(OFN.lpstrFileTitle))
    Else
        cderr = CommDlgExtendedError
        GoTo ex
    End If
    MP3Play hWnd, nFileName
    butPause.Enabled = True
    butStop.Enabled = True
    butStart.Enabled = True
    butExit.Enabled = True
    Exit Sub
ex:
    butSelect.Enabled = True
    butExit.Enabled = True
End Sub

' Проверка игры
Public Function IsPlaying() As Boolean
    Static s As String * 30
    mciSendString "status MP3Play mode", s, Len(s), 0
    IsPlaying = (Mid$(s, 1, 7) = "playing")
End Function

03. Если Вас не устраивает однотипный цвет таблиц запросов, то использование этого метода позволит вам раскрасить отдельные поля запроса.

'==============================================================
'   Установить формат поля
Private Sub butExecute_Click()
Dim dbs As Database, obj As Object
    On Error GoTo 999
        Set dbs = CurrentDb
        Set obj = dbs.QueryDefs("Запрос 03").Fields("Сумма03")
        SetFieldProperty obj, "Format", dbChar, "0.00;0.00;0.00;0[Red]"
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Изменение поля"
    Err.Clear
End Sub

'==============================================================
'   Удалить формат поля
Private Sub butDelProp_Click()
Dim dbs As Database, obj As Object
    On Error GoTo 999
        Set dbs = CurrentDb
        Set obj = dbs.QueryDefs("Запрос 03").Fields("Сумма03")
        SetFieldProperty obj, "Format", dbChar, "0;0;0"
    Exit Sub
999:
    MsgBox Err.Description, vbCritical, "Удаление поля"
    Err.Clear
End Sub

'==============================================================
'   Установить свойство поля запроса
Private Sub SetFieldProperty(obj As Object, _
        prpName As String, _
        prpType As Integer, _
        prpValue As Variant)
Dim prp As Variant
    On Error GoTo 999
    obj.Properties(prpName) = prpValue
    obj.Properties.Refresh
    MsgBox "Свойство изменено!", vbExclamation, "Свойства"
    Exit Sub
999:
    Err.Clear
    Set prp = obj.CreateProperty(prpName, prpType, prpValue)
    obj.Properties.Append prp
    obj.Properties.Refresh
End Sub

08. Очень часто встречается так, что одна таблица подчиняется другой. Например, накладные, а у них есть спецификация. Если создать соотношение один ко многим, то у таблицы появляется поле [+]. Нажав на него, можно увидеть подчиненную таблицу.