LEADERSOFT.ru Разработка на заказ программ и сайтов
Раздел обучения информационным технологиям
Разработка программ на Access
02. Данный способ позволяет вам нарисовать некоторые объекты в форме, хотя в программе Международный Туризм использовался другой алгоритм для рисования карты. Этот способ может Вам пригодится в некоторых случаях. Рисуются линии, точки, элипсы, многоугольники, т.е. те базовые объекты, которые применяются в api интерфейсе.
Свойства продукта

 Microsoft Office: 2000,2002,2003,2007,2010  Архив с файлами: Перейти
 Операционная система: Windows XP,Vista  Применение: Базы данных Access
 Продажа: Купить  Файл исходника: ..\Access\02 Графика\la_graphics.mdb
 Язык интерфейса: Русский

   

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

' Функция возвращает контекст устройства для рисования
Private Declare Function apiGetDC Lib "user32" Alias "GetDC" _
    (ByVal hwnd As Long) _
    As Long
 
' Функция освобождает контекст устройства для других приложений
Private Declare Function apiReleaseDC Lib "user32" Alias "ReleaseDC" _
    (ByVal hwnd As Long, _
    ByVal hDc As Long) _
    As Long

'==============================================================
' Далеее идут, функции управляющие рисованием

' Функция рисует точку на экране
Private Declare Function apiSetPixel Lib "gdi32" Alias "SetPixel" _
    (ByVal hDc As Long, _
     ByVal As Long, _
     ByVal As Long, _
     ByVal crColor As LongAs Long

' Функция рисует линию из текущей позиции "пера" до точки с координатами
' x,y, но не включая ее саму. Линия рисуется с помощью выбранного "пера". Если
' нет ошибки, то текущее положение пера устанавливается в точку с координатами
' (x,y)
Private Declare Function apiLineTo Lib "gdi32" Alias "LineTo" _
    (ByVal hDc As Long, _
    ByVal As Integer, _
    ByVal As Integer) _
    As Long

' Функция рисует дугу элипса с помощью выбранного "пера".
' Дуга рисуется против часовой стрелки.
' (x1,y1  - x2,y2) ограничивающий прямоугольник для дуги.
' (x3,y3) - начальная точка рисования "пером"
' (x4,y4) - конечная точка рисования дуги
Private Declare Function apiArc Lib "gdi32" Alias "Arc" _
    (ByVal hDc As Long, _
    ByVal X1 As Integer, _
    ByVal Y1 As Integer, _
    ByVal X2 As Integer, _
    ByVal Y2 As Integer, _
    ByVal X3 As Integer, _
    ByVal Y3 As Integer, _
    ByVal X4 As Integer, _
    ByVal Y4 As Integer) _
    As Long
' Функция рисует прямоугольник с помощью выбранного "пера".
' (x1,y1) - первый угол
' (x2,y2) - противоположный угол
Private Declare Function apiRectangle Lib "gdi32" Alias "Rectangle" _
    (ByVal hDc As Long, _
    ByVal X1 As Long, _
    ByVal Y1 As Long, _
    ByVal X2 As Long, _
    ByVal Y2 As LongAs Long

' Функция передвигает позицию рисования
' (x,y) - новая точка
' (lpPoint) - предыдущая точка
Private Declare Function apiMoveTo Lib "gdi32" Alias "MoveToEx" _
    (ByVal hDc As Long, _
     ByVal As Long, _
     ByVal As Long, _
     lpPoint As POINTAPI) As Long
' Структура координаты точки
Private Type POINTAPI
    x As Long
    Y As Long
End Type

' Функция рисует элипс с помощью выбранного "пера".
' (x1,y1) - первый угол
' (x2,y2) - противоположный угол
Private Declare Function apiEllipse Lib "gdi32" Alias "Ellipse" _
    (ByVal hDc As Long, _
     ByVal X1 As LongByVal Y1 As Long, _
     ByVal X2 As LongByVal Y2 As LongAs Long

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

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

' Функция заливает круг с помощью выбранного "пера"
' (x1,y1  - x2,y2) ограничивающий прямоугольник для дуги
' (x3,y3) - начальная точка рисования "пером"
' (x4,y4) - конечная точка рисования дуги
Private Declare Function apiChord Lib "gdi32" Alias "Chord" _
    (ByVal hDc As Long, _
     ByVal X1 As LongByVal Y1 As Long, _
     ByVal X2 As LongByVal Y2 As Long, _
     ByVal X3 As LongByVal Y3 As Long, _
     ByVal X4 As LongByVal Y4 As LongAs Long

' Функция заливает круг с помощью выбранного "пера"
' (x1,y1  - x2,y2) ограничивающий прямоугольник для дуги
' (x3,y3) - начальная точка рисования "пером"
' (x4,y4) - конечная точка рисования дуги
Private Declare Function apiPie Lib "gdi32" Alias "Pie" _
    (ByVal hDc As Long, _
     ByVal X1 As LongByVal Y1 As Long, _
     ByVal X2 As LongByVal Y2 As Long, _
     ByVal X3 As LongByVal Y3 As Long, _
     ByVal X4 As LongByVal Y4 As LongAs Long

'==============================================================
'  Назначение
'    Нарисовать объекты
'
Private Sub butExecute_Click()
Dim hwnd As Long, hDc As Long 'Окно и контекст рисования
Dim X1 As Long, Y1 As Long, X2 As Long, Y2 As Long
Dim xy(3) As POINTAPI 'Точки рисования
On Error GoTo 999
 
    'Очистить зону рисования
    Me.Refresh
    DoEvents
    
    'Поиск окна для рисования. Это решение предложено
    'Николаем Малютиным г.Якутск: malnik@mail.ru
    hwnd = FindWindowEx(Me.hwnd, FindWindowEx(Me.hwnd, 0, "OFormSub"""), "OFormSub""")
    
    'Выбираем контекст устройства
    hDc = apiGetDC(hwnd)
    
    'Координаты зоны рисования
    X1 = 15
    Y1 = 90
    X2 = 180
    Y2 = 250
    
    'Рисуем объекты
    Select Case Me.Объекты
        Case 1: 'Точка - красная
            Call apiSetPixel(hDc, X2 / 2, Y2 / 2, RGB(255, 0, 0))
        Case 2: 'Линия
            Call apiMoveTo(hDc, X1, Y1, xy(0)) 'Передвигаем указатель
            Call apiLineTo(hDc, X2, Y2) 'Рисуем линию
        Case 3: 'Элипс
            Call apiEllipse(hDc, X1, Y1, X2, Y2 / 2)
        Case 4: 'Прямоугольник - закрашенный
            Call apiRectangle(hDc, X1, Y1, X2, Y2)
        Case 5: 'Дуга
            Call apiArc(hDc, X1, Y1, X2, Y2, 50, 100, 150, 150)
        Case 6, 7: 'Ломаная, Заливка
            ' Загружаем координаты
            xy(0).x = X1
            xy(0).Y = Y1
            xy(1).x = X1 + 20
            xy(1).Y = Y2
            xy(2).x = X2
            xy(2).Y = Y2 - 20
            If Me.Объекты = 6 Then 'Ломаная
                Call apiPolyline(hDc, xy(0), UBound(xy))
            Else 'Заливка
                Call apiPolygon(hDc, xy(0), UBound(xy))
            End If
        Case 8: 'Заливка круга до хорды
            Call apiChord(hDc, X1, Y1, X2, Y2, 50, 100, 150, 150)
        Case 9: 'Заливка круга из центра
            Call apiPie(hDc, X1, Y1, X2, Y2, 50, 100, 150, 150)
    End Select
    
    'Освобождаем контекст устройства
    Call apiReleaseDC(hwnd, hDc)
    Exit Sub
999:
    MsgBox Err.Description  'Ошибка
    Err.Clear
End Sub

Copyright © 2002-2015 ООО Лидер Эксэсс
Сайт работает под управлением: ASP.NET, Access