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

Данный пример показывает как можно редактировать тексты rtf в Microsoft Access.

'сохранение текущей записи в файле в формате RTF
Private Sub cmdSave_Click()
    Me.RichTextBox1.SaveFile CurrentProject.Path  "\rtftemp"  Me.ID  ".rtf"
End Sub

'сохранение всех записей в файле в формате RTF
Private Sub cmdSaveAll_Click()
Dim i As Long, p As Long
Dim strtemp As String, strrtf As String
    'разделитель записей (по желанию)
    Const spl = "\rtf1\ansi\ansicpg1251\deff0\deflang1049{\fonttbl{\f0\fnil\fcharset0 Tahoma;}}"  _
    "\viewkind4\uc1\pard\f0\fs24 ************************************"  _
    "\par"
    
    'сведем все записи воедино
    DoCmd.GoToRecord , , acFirst
    DoCmd.Echo False
    For i = 1 To DCount("[ID]", "T1")
         strtemp = Me.RichTextBox1.TextRTF
         'для "нормального" склеивания фрагментов текста надо удалить лишние "}" "{"
         p = InStrRev(strtemp, "}")
         strtemp = Left(strtemp, p - 1)
         p = InStr(strtemp, "{")
         strtemp = Right(strtemp, Len(strtemp) - p)
         strrtf = strrtf  strtemp  spl
         DoCmd.GoToRecord , , acNext
    Next i
    DoCmd.GoToRecord , , acFirst
    DoCmd.Echo True
    
    'восстановим начальные и конечные "{"
    strrtf = "{"  strrtf  "}"
    
    'чтобы полученный не влиял на данные, отключим RichTextBox от данных
    strtemp = Me.RichTextBox1.ControlSource
    Me.RichTextBox1.ControlSource = ""
    Me.RichTextBox1.TextRTF = strrtf
    
    Me.RichTextBox1.SaveFile CurrentProject.Path  "\rtftempall.rtf"
    
    'восстановим нормальную работу
    Me.RichTextBox1.ControlSource = strtemp
End Sub

'управление насыщенностью
Private Sub ctlBold_AfterUpdate()
    Select Case Me.ctlBold.Value
    Case -1
    Me.RichTextBox1.SelBold = True
    Case 0
    Me.RichTextBox1.SelBold = False
    End Select
    Me.RichTextBox1.SetFocus
End Sub

03. Это делается в конструкторе отчетов, поэтому для понимания этого примера откройте mdb файл

03. Первая часть - при загрузке формы скрывается ее заголовок. Средствами Access можно убрать строку меню и границу, но тогда форма не имеет четко выраженной границы. Вторая часть - рисование полилиний разного цвета. При построении графиков для наглядности удобно представлять данные разными цветами в зависимости от уровня стандартные средства этого почему-то не поддерживают. Третья часть - пример использования регионов.

'константы для функции пересчета твипов
'значения 88 и 90 могут отличаться!
Public Const LOGPIXELSX = 88
Public Const LOGPIXELSY = 90

'константы для функции скрытия заголовка
Public Const STYLE = (-16)
Public Const CAPTION = HC00000
Public Const BORDER = H800000
Public Const NOMOVE = H2
Public Const NOSIZE = H1
Public Const NOZODER = H4
Public Const ShowWindow = H40
Public Const NOACTIVE = H10
Public Const FRAMECHANGED = H20

'вычисление коэффициента пересчета Twip в Pixel
Public Function TwipToPixel(i As Long) As Long
    Dim hDc As Long
    'получение идентификатора контеста устройства
    hDc = GetDC(0)
    Select Case i
    Case 1
    TwipToPixel = 1440 / GetDeviceCaps(hDc, LOGPIXELSX)
    Case 2
    TwipToPixel = 1440 / GetDeviceCaps(hDc, LOGPIXELSY)
    End Select
    'освобождение идентификатора
    ReleaseDC 0, hDc

End Function
'--
'GetDC возвращает контекст устройства (DC) окна
Public Declare Function GetDC Lib "user32" (ByVal hw As Long) As Long
'ReleaseDC освобождает ресурсы,которые были заняты
'при использовании GetDC для получения контекста устройства
Public Declare Function ReleaseDC Lib "user32" (ByVal hw As Long, ByVal hDc As Long) As Long

'получение характеристи�� дисплея
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, _
   ByVal iCapability As Long) As Long

'функция позволяет получить используемый стиль окна
Public Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long) As Long

'функция позволяет установить новый стиль окна
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" _
 (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
 
'функция отображает окно в указанном месте
Public Declare Function SetWindowPos Lib "user32.dll" _
(ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, _
ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal _
wFlags As Long) As Long

' Функция используется для поиска окна
 Public Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA" _
  (ByVal hWndParent As Long, _
   ByVal hWndChildAfter As Long, _
   ByVal lpClassname As String, _
   ByVal lpWindowName As String) As Long

' Функция рисует ломаную с помощью выбранного "пера"
Public Declare Function Polygon Lib "gdi32" (ByVal hDc As Long, _
     lpPoint As POINTAPI, ByVal nCount As Long) As Long

' Функция рисует ломаную с помощью выбранного "пера"
Public Declare Function Polyline Lib "gdi32" (ByVal hDc As Long, _
     lpPoint As POINTAPI, _
     ByVal nCount As Long) As Long



' Структура координаты точки
Public Type POINTAPI
    x As Long
    Y As Long
End Type


'функция выбирает устройство для рисования
Public Declare Function SelectObject Lib "gdi32.dll" (ByVal hDc _
As Long, ByVal hObject As Long) As Long

'функция удаляет созданный объект для освобождения ресурсов
Public Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject _
As Long) As Long

'функция создает новое "перо"
Public Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle _
As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long

'функция создает новую "кисть"
Public Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal _
crColor As Long) As Long

'функция создает прямоугольный регион
Public Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, _
ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long

'функция создает комбинацию из двух регионов
Public Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As _
Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal _
nCombineMode As Long) As Long

'функция отображает регион на окно
Public Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As _
Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long

'функция позволяет получить размеры и положение окна
Public Declare Function GetWindowRect Lib "user32" (ByVal hwnd As _
Long, lpRect As Rect) As Long

'структура для данных, получаемых GetWindowRect
 Public Type Rect
  left As Long
  top As Long
  right As Long
  bottom As Long
End Type

'функция управляет "показом" окна
Private Declare Function ShowWindow Lib "user32" (ByVal hwnd As _
Long, ByVal nCmdShow As Long) As Long
'--



Public Function Скрыть_Заголовок(frm As Form, IndexX As Long, IndexY As Long)
    Dim OldStyle As Long, NewStyle As Long
    Dim x As Long, Y As Long
    
    'получение текушего стиля окна
    OldStyle = GetWindowLong(frm.hwnd, STYLE)
    
    'определение и установка нового стиля окна
    NewStyle = (OldStyle And Not CAPTION) Or BORDER
    SetWindowLong frm.hwnd, STYLE%, NewStyle
    
    'настройка размеров окна
    x = frm.Width \ IndexX
    Y = frm.Section(acDetail).Height \ IndexY
    
    'отображение окна с новыми свойствами
    SetWindowPos frm.hwnd, 0, 0, 0, x, Y, NOMOVE Or NOZODER Or FRAMECHANGED

End Function

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

13. Если Вы разрабатываете интерфейс в зависимости от разных ролей пользователей, которым нужно разрешить или запретить редактирование формы, то используйте этот пример.

Private Sub butEdit_Click()
Dim frm As Form
    Set frm = [Form_Пример 13 пдч]
    frm.AllowAdditions = Me.butEdit 'Разрешить добавление
    frm.AllowDeletions = Me.butEdit 'Разрешить удаление
    frm.AllowEdits = Me.butEdit     'Разрешить редактирование
    If Me.butEdit = True Then 'Если разрешено редактирование
        Me.butEdit.Caption = "Отменить редактирование" 'Текст кнопки
        Me.butEdit.ForeColor = 255 'Цвет символов
    Else
        Me.butEdit.Caption = "Включить редактирование"
        Me.butEdit.ForeColor = 0
    End If
End Sub

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

Private Sub Form_Open(Cancel As Integer)
    Me.Итого.ControlSource = "=[Сумма]*[Наценка]"
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

12. При разработке баз данных очень часто встречаются случаи, когда необходимо автоматическим способом заполнить поля в форме. Это показано в этом примере

'==============================================================
' Заполнение реквизитов
Private Sub allFirms_AfterUpdate()
Dim rst As Recordset
    On Error GoTo 999
    Set rst = CurrentDb.OpenRecordset("SELECT * FROM [Фирмы] WHERE [Фирма]='"  Me.allFirms  "'")
    If rst.RecordCount  0 Then
        With rst
            'Форму Вы можете связать с таблицей
            Me.Фирма = rst!Фирма
            Me.Банк = rst!Банк
            Me.Счет = rst!Счет
            Me.КорСЧЕТ = rst!КорСчет
        End With
    End If
    rst.Close
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

' Определяем максимальный номер документа
Private Sub Form_Current()
    If Me.NewRecord = True Then
       Me.Nдок.DefaultValue = 1 + funGetMaxNumber("SELECT Max([Nдок]) as NN FROM [Пример 12]")
    End If
End Sub

'==============================================================
' Получаем максимальное число
Function funGetMaxNumber(sSQL As String) As Long
Dim dbs As Database, rst As Recordset
    funGetMaxNumber = 0
    On Error GoTo 999
    Set dbs = CurrentDb
    Set rst = dbs.OpenRecordset(sSQL)
    If rst.RecordCount  0 Then
        funGetMaxNumber = rst![NN]
    End If
    rst.Close
    Exit Function
999:
    Err.Clear
End Function

11. Выделить всю строки в форме возможно, если Вы используете программных код указанный в описании.

Private Sub Form_Current()
Dim N As Long
    On Error Resume Next
    Me.Repaint
    N = Me.SelTop
    If N  1 Then N = 1
    Me.SelTop = N
    Me.SelLeft = 1
    Me.SelWidth = 10
    Me.SelHeight = 1
    Err.Clear
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