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

Microsoft Access. Интеллектуальный поиск

09 сентября 2022 Admin (0)

03. Есть таблица, в ней нужно провести поиск. При этом известно, что пользователь не знает Русского языка и допускает ошибки в словах. Этот пример решает такую проблему.

Option Compare Database
Option Explicit

'Функция нечеткого сравнения строк, смотрите применение в
'форме: Example 03
'
'метод предложен Кива Владимир vlak@glasnet.ru
'http://www.glasnet.ru/~vlak/similar/similar.html
'
'Программирование: Николай Малютин, malnik@mail.ru
'
'lngMaxLen - максимальная длина подстроки (достаточно 3-4)
'strStringMatching - сравниваемая строка
'strStringStandart - строка-образец
'

Private Type RetCount
    lngSubRows As Long
    lngCountLike As Long
End Type

Public Function IndistinctMatching(lngMaxLen As Long, strStringMatching As String, strStringStandart As String, lngCase As Long) As Long
Dim gret As RetCount
Dim tret As RetCount
Dim lngCurLen As Long   'текущая длина подстроки

    'если не передан какой-либо параметр, то выход
    If lngMaxLen = 0 Or Len(strStringMatching) = 0 Or Len(strStringStandart) = 0 Then
        IndistinctMatching = 0
        Exit Function
    End If
    
    gret.lngCountLike = 0
    gret.lngSubRows = 0
    For lngCurLen = 1 To lngMaxLen
        'Сравниваем строку A со строкой B
        tret = MatchingStrings(strStringMatching, strStringStandart, lngCurLen, lngCase)
        gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
        gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
        'Сравниваем строку B со строкой A
        tret = MatchingStrings(strStringStandart, strStringMatching, lngCurLen, lngCase)
        gret.lngCountLike = gret.lngCountLike + tret.lngCountLike
        gret.lngSubRows = gret.lngSubRows + tret.lngSubRows
    Next lngCurLen
    
    If gret.lngSubRows = 0 Then
        IndistinctMatching = 0
        Exit Function
    End If
    IndistinctMatching = (gret.lngCountLike / gret.lngSubRows) * 100
End Function

Private Function MatchingStrings(strA As String, strB As String, lngLen As Long, lngCase As Long) As RetCount
Dim tret As RetCount
Dim y As Long, z As Long
Dim strta As String
Dim strtb As String
    For z = 1 To Len(strA) - lngLen + 1
       strta = Mid(strA, z, lngLen)
       y = 1
       For y = 1 To Len(strB) - lngLen + 1
          strtb = Mid(strB, y, lngLen)
          If StrComp(strta, strtb, lngCase) = 0 Then
          tret.lngCountLike = tret.lngCountLike + 1
          Exit For
          End If
       Next y
    tret.lngSubRows = tret.lngSubRows + 1
    Next z
    MatchingStrings.lngCountLike = tret.lngCountLike
    MatchingStrings.lngSubRows = tret.lngSubRows
End Function

Microsoft Access. Подсчитаем число записей в отчете.

09 сентября 2022 Admin (0)

Суть примера в том, что когда формируется отчет, то используя событие форматирования, можно еще до его открытия узнать сколько записей будет в отчете.

Dim cnt As Long ' Число записей

'===============================================================
' Обнуляем информацию по отчету
Private Sub Report_Open(Cancel As Integer)
    cnt = 0
End Sub

'===============================================================
' Считаем данные
Private Sub ОбластьДанных_Print(Cancel As Integer, PrintCount As Integer)
Dim rpt As Report
    On Error GoTo 999
    'Находим в запросе нужную запись
    cnt = cnt + 1
    Me.CountRpt.Caption = Me.Page  "/"  cnt
    Exit Sub
999:
    Err.Clear
End Sub

' Печатаем информацию для каждого колонтитула
Private Sub ВерхнийКолонтитул_Format(Cancel As Integer, FormatCount As Integer)
    Me.headpage.Caption = "Страница: "  Me.Page  "/"  cnt
End Sub

Microsoft Access. Изменение отчетов при открытии

09 сентября 2022 Admin (0)

19. Можно создать два разных отчета, а для их объединения использовать Главный отчет. При его открытии можно изменить вид отчета, если поменять источник. Смотрите этот пример.

Private Sub Report_Open(Cancel As Integer)
    If MsgBox("Изменить поля отчета?", vbInformation + vbOKCancel) = vbOK Then
        Me.subReport.SourceObject = "Отчет.Пример 19_sub2"
    End If
End Sub

Microsoft Access. Как вывести в отчете сумму на каждом листе

09 сентября 2022 Admin (0)

18. У меня в отчете несколько листов. Приходится общую сумму листа считать вручную. Общую сумму отчета делать умею, но вот каждого листа в отдельности нет. Этот небольшой пример решает такую задачу.

Private sumPage As Currency, strMsg As String

Private Sub ОбластьДанных_Format(Cancel As Integer, FormatCount As Integer)
    sumPage = Me.Цена.Value + sumPage
    strMsg = strMsg  Me.Пункт  ".  "  Me.Цена.Value  vbNewLine
End Sub

Private Sub НижнийКолонтитул_Format(Cancel As Integer, FormatCount As Integer)
    Me.PageИтого.Value = sumPage
    MsgBox strMsg
    sumPage = 0
    strMsg = ""
End Sub

Microsoft Access. Вывод отчета в две колонки

09 сентября 2022 Admin (0)

17. Это свойство вывода на печать поможет напечатать отчет в несколько колонок (как на газетном листе). Настраивается через конструктор.

Option Compare Database
Option Explicit

Private Type str_DEVMODE
    RGB As String * 94 'Промежуточная переменная для копирования
End Type

'Полное описание структуры дано в модуле: p001.mdb
Private Type type_DEVMODE
    strDeviceName As String * 16
    intSpecVersion As Integer
    intDriverVersion As Integer
    intSize As Integer
    intDriverExtra As Integer
    lngFields As Long
    intOrientation As Integer
    intPaperSize As Integer
    intPaperLength As Integer
    intPaperWidth As Integer
    intScale As Integer
    intCopies As Integer
    intDefaultSource As Integer
    intPrintQuality As Integer
    intColor As Integer
    intDuplex As Integer
    intResolution As Integer
    intTTOption As Integer
    intCollate As Integer
    strFormName As String * 16
    lngPad As Long
    lngBits As Long
    lngPW As Long
    lngPH As Long
    lngDFI As Long
    lngDFr As Long
End Type

'==============================================================
' Открытие отчета
Private Sub Form_Open(Cancel As Integer)
    funChangeReport False
End Sub

'==============================================================
' Открыть отчет
Private Sub butChange_Click()
    On Error GoTo 999
    DoCmd.OpenReport "Пример 16", acViewPreview 'Открываем конструктор отчета
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

'==============================================================
' Изменяем размеры отчета
Private Sub myWidth_AfterUpdate()
    funChangeReport True
End Sub

'==============================================================
' Изменяем размеры отчета
Private Sub myLength_AfterUpdate()
    funChangeReport True
End Sub

'==============================================================
' Изменяем размеры отчета
'
Private Sub funChangeReport(boolChange As Boolean)
    Dim DevString As str_DEVMODE
    Dim DM As type_DEVMODE
    Dim strDevModeExtra As String
    Dim rpt As Report
    On Error GoTo 999
    DoCmd.OpenReport "Пример 16", acDesign 'Открываем конструктор отчета
    Set rpt = Reports("Пример 16") 'Определяем адрес отчета
    If Not IsNull(rpt.PrtDevMode) Then
        strDevModeExtra = rpt.PrtDevMode
        DevString.RGB = strDevModeExtra 'Структура отчета
        LSet DM = DevString 'Заполняем структуру
        If boolChange = True Then 'Изменение отчета
            On Error Resume Next
            rpt.Width = 32000
            Err.Clear
            DM.lngFields = DM.lngFields Or _
              DM.intPaperSize Or DM.intPaperLength Or DM.intPaperWidth
            DM.intPaperSize = 256 'Устанавливаем тип листа
            DM.intPaperWidth = Me.myWidth * 10 'Новая ширина
            DM.intPaperLength = Me.myLength * 10 'Новая длина
            LSet DevString = DM  'Обновляем свойство
            Mid(strDevModeExtra, 1, 94) = DevString.RGB
            rpt.PrtDevMode = strDevModeExtra
            DoCmd.Close acReport, "Пример 16", acSaveYes 'Закрываем отчет
        Else 'Отображение данных
            Me.myWidth = DM.intPaperWidth / 10 'Ширина
            Me.myLength = DM.intPaperLength / 10 'Ширина
            DoCmd.Close acReport, "Пример 16" 'Закрываем отчет
        End If
    End If
    Exit Sub
999:
    MsgBox Err.Description
End Sub

Microsoft Access. Как изменить размеры листа отчета

09 сентября 2022 Admin (0)

16. Используя специальное свойства отчетов Access, где можно указать специальную структуру параметров для печати, Вы сможете из Access управлять размерами бумаги для печати.

Option Compare Database
Option Explicit

Private Type str_DEVMODE
    RGB As String * 94 'Промежуточная переменная для копирования
End Type

'Полное описание структуры дано в модуле: p001.mdb
Private Type type_DEVMODE
    strDeviceName As String * 16
    intSpecVersion As Integer
    intDriverVersion As Integer
    intSize As Integer
    intDriverExtra As Integer
    lngFields As Long
    intOrientation As Integer
    intPaperSize As Integer
    intPaperLength As Integer
    intPaperWidth As Integer
    intScale As Integer
    intCopies As Integer
    intDefaultSource As Integer
    intPrintQuality As Integer
    intColor As Integer
    intDuplex As Integer
    intResolution As Integer
    intTTOption As Integer
    intCollate As Integer
    strFormName As String * 16
    lngPad As Long
    lngBits As Long
    lngPW As Long
    lngPH As Long
    lngDFI As Long
    lngDFr As Long
End Type

'==============================================================
' Открытие отчета
Private Sub Form_Open(Cancel As Integer)
    funChangeReport False
End Sub

'==============================================================
' Открыть отчет
Private Sub butChange_Click()
    On Error GoTo 999
    DoCmd.OpenReport "Пример 16", acViewPreview 'Открываем конструктор отчета
    Exit Sub
999:
    MsgBox Err.Description
    Err.Clear
End Sub

'==============================================================
' Изменяем размеры отчета
Private Sub myWidth_AfterUpdate()
    funChangeReport True
End Sub

'==============================================================
' Изменяем размеры отчета
Private Sub myLength_AfterUpdate()
    funChangeReport True
End Sub

'==============================================================
' Изменяем размеры отчета
'
Private Sub funChangeReport(boolChange As Boolean)
    Dim DevString As str_DEVMODE
    Dim DM As type_DEVMODE
    Dim strDevModeExtra As String
    Dim rpt As Report
    On Error GoTo 999
    DoCmd.OpenReport "Пример 16", acDesign 'Открываем конструктор отчета
    Set rpt = Reports("Пример 16") 'Определяем адрес отчета
    If Not IsNull(rpt.PrtDevMode) Then
        strDevModeExtra = rpt.PrtDevMode
        DevString.RGB = strDevModeExtra 'Структура отчета
        LSet DM = DevString 'Заполняем структуру
        If boolChange = True Then 'Изменение отчета
            On Error Resume Next
            rpt.Width = 32000
            Err.Clear
            DM.lngFields = DM.lngFields Or _
              DM.intPaperSize Or DM.intPaperLength Or DM.intPaperWidth
            DM.intPaperSize = 256 'Устанавливаем тип листа
            DM.intPaperWidth = Me.myWidth * 10 'Новая ширина
            DM.intPaperLength = Me.myLength * 10 'Новая длина
            LSet DevString = DM  'Обновляем свойство
            Mid(strDevModeExtra, 1, 94) = DevString.RGB
            rpt.PrtDevMode = strDevModeExtra
            DoCmd.Close acReport, "Пример 16", acSaveYes 'Закрываем отчет
        Else 'Отображение данных
            Me.myWidth = DM.intPaperWidth / 10 'Ширина
            Me.myLength = DM.intPaperLength / 10 'Ширина
            DoCmd.Close acReport, "Пример 16" 'Закрываем отчет
        End If
    End If
    Exit Sub
999:
    MsgBox Err.Description
End Sub

Microsoft Access. Добавление текстовых меток в отчет

09 сентября 2022 Admin (0)

10. Этот пример показывает, как можно добавить в отчет текст, например, комментарий расположенный не в таблице, а некотором месте.

Private Sub ОбластьДанных_Print(Cancel As Integer, PrintCount As Integer)
    funDrawText Me, 2700, "Наименование", "Распродажа" 'Добавляем в ячейку текст
    funDrawText Me, 50, "Цена", "Новая" 'Добавляем в ячейку текст
End Sub

'===============================================================
' Рисуем в поле текст strCaption в соответствии с условием
'
Private Function funDrawText(rpt As Report, pos As Single, strField As String, strCaption) As Long
Dim c As Control, h As Integer
        Set c = rpt.Section(acDetail).Controls(strField)
        h = rpt.FontSize 'Начальная высота шрифта
        If c  30 Then 'Условие для поля
            rpt.ScaleMode = 1 'Назначаем масштаб в твипах
            rpt.FontName = c.FontName  'Назначаем шрифт ячейки
            rpt.FontSize = 7  'Назначаем высоту текста
            rpt.ForeColor = RGB(255, 0, 0) 'Назначаем цвет
            rpt.CurrentX = pos + c.Left 'x координата текста в твипах
            rpt.CurrentY = 0 'y координата текста
            rpt.Print strCaption 'Печататем текст
        End If
        'Пример другого поля
        If strField = "Наименование" Then
            rpt.FontSize = 7  'Назначаем высоту текста
            rpt.ForeColor = RGB(0, 0, 255) 'Назначаем цвет
            rpt.CurrentX = pos + c.Left 'x координата текста в твипах
            rpt.Print strCaption 'Печататем текст
        End If
        
        rpt.FontSize = h 'Возвращаем размер шрифта для отчета
End Function

Microsoft Access. Добавление поля в отчет mde файла

09 сентября 2022 Admin (0)

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

Dim rstRpt As Recordset 'Запрос отчета
Dim x0 As Single 'Крайняя правая точка

'===============================================================
' Открываем запрос отчета и определяем параметры секции
Private Sub Report_Open(Cancel As Integer)
Dim dbs As Database, c As Control
    Set dbs = CurrentDb 'Выбираем базу данных
    Set rstRpt = dbs.OpenRecordset(Me.RecordSource) 'Открываем запрос
    'Находим последнее поле в отчете
    x0 = 0 'Инициализация
    For Each c In Me.Section(acDetail).Controls 'Просматриваем всю секцию
       If x0  c.Left + c.Width Then _
               x0 = c.Left + c.Width 'Крайняя правая точка в отчете
    Next c
End Sub

'===============================================================
' Находим запись отчета и печатаем текст
'
Private Sub ОбластьДанных_Print(Cancel As Integer, PrintCount As Integer)
Dim rpt As Report
    On Error GoTo 999
    'Находим в запросе нужную запись
    rstRpt.FindFirst "[Номенклатура]="  Me.Controls("Номенклатура")
    'Форматируем поле и добавляем в отчет после всех полей
    funDrawControl Me, 567 * 2, Format(rstRpt!Цена, "# ##0.00") 'Добавляем в ячейку текст
999:
    Err.Clear
End Sub

'===============================================================
' Рисуем элемент управления для отчета
'   myWidth - ширина поля
'   strDate - данные поля
'   Внимание! TextWidth может вернуть неправильный результат,
'             требуется пакет обновления SR-1
Private Function funDrawControl(rpt As Report, myWidth As Single, strDate) As Long
Dim c As Control
    
    'Пример текста в поле, который строится по образцу
    'Set c = Me.Section(acDetail).Controls("Номенклатура") 'Образец шрифта
    'Me.FontName = c.FontName  'Назначаем шрифт ячейки
    'Me.FontSize = c.FontSize  'Назначаем высоту текста
    'Me.ScaleMode = 1 'Назначаем масштаб в твипах
    
    'Расчитываем позицию текста и печаем его
    rpt.CurrentY = (rpt.Height - rpt.TextHeight("0")) / 2 'y-координата текста
    rpt.CurrentX = x0 + myWidth - rpt.TextWidth(strDate) 'x-координата текста
    rpt.ForeColor = RGB(255, 0, 0) 'Цвет текста
    rpt.Print strDate 'Печатаем текст
    
    'Рисуем прямоугольник вокруг поля
    rpt.ForeColor = RGB(255, 0, 0) 'Назначаем цвет
    rpt.Line (x0, 0)-(x0 + myWidth, rpt.Height), , B 'Прямоугольник
End Function

'===============================================================
' Закрываем запрос отчета
Private Sub Report_Close()
    rstRpt.Close
End Sub

Microsoft Access. Переменная высота строк в отчете

09 сентября 2022 Admin (0)

09. Программа построения табличных отчетов от Microsoft составлена так, что при изменении данных (1 строка, 2 строки) они могут не отображаться, т.к. в конструкторе эта высота уазывается жестко. Этот метод позволяет Вам обойти недостаток модуля отчетов от Microsoft и строить таблицы разной высоты.

Private Sub ОбластьДанных_Print(Cancel As Integer, PrintCount As Integer)
Dim h As Single
    h = funGetHeight(Me.Section(acDetail)) 'Опредеяем высоту строки
    funDrawBox Me, h, 1 'Оформляем секцию с толщиной линий = 1
End Sub

'===============================================================
' Расчет высоты строки в секции в зависимости от форматирования
' поля отчета, например, TextBox
'
Private Function funGetHeight(sec As Section) As Single
Dim c As Control
     funGetHeight = 0 'назначаем высоту ячейки
     For Each c In sec.Controls 'Просматриваем все поля отчета
         If funGetHeight  c.Height Then _
            funGetHeight = c.Height 'Возвращаем максимальную высоту
     Next c 'Следующее поле
End Function

'===============================================================
' Перед началом печати рисуем для каждого поля прямоугольник
'
Private Sub funDrawBox(rpt As Report, h As Single, w As Integer)
Dim c As Control
     rpt.DrawWidth = w 'Толщина линии
     'Красный цвет прямоугольника
     rpt.ForeColor = RGB(255, 0, 0) 'RED, GREEN, BLUE
     'Просматриваем все поля отчета
     For Each c In rpt.Section(acDetail).Controls
         rpt.Line (c.Left, c.Top)-(c.Left + c.width, h), , B 'Прямоугольник
     Next c
End Sub

Microsoft Access. Группировка записей в запросах

09 сентября 2022 Admin (0)

Когда Вам надо сгруппировать записи в запросах, например, найти сумму в колонке таблицы, то используйте вместе SELECT ключевое слово GROUP BY

-- Использование группировки
SELECT First(Книга) as Книги, avg(СуммаРуб) as [Средняя Цена] FROM [Данные] GROUP BY Книга

-- Выборка после группировки
SELECT First(Книга) as Книги, Avg(СуммаРуб) as [Средняя Цена] FROM [Данные] GROUP BY Книга 
HAVING Avg(СуммаРуб)350