Часть вторая посвящена работе с картинками, по контуру которых происходит "вырезание". Здесь вынужден с прискорбием заметить, что не все графические форматы удовлетворяют для этой работы. Например, наиболее популярный формат JPG, обладающий хорошим сжатием абсолютно не подходит из-за невозможности создать ровный однотонный фон для исключаемого цвета. Формат GIF, так же ограничен в применении, но по другой причине - он поддерживает только 256 цветов, что не позволяет в полной мере использовать фотографические изображения. В итоге нам остается стандартный BMP, поддерживающий возможность фотографического изображения и исключения однотонного фонового цвета, но, к сожалению, достаточно большой по объему.
Принципы работы с вырезанием графического изображения по контуру остаются теми же, что и описанные в 1-ой части. А именно:
И если последние два пункта остаются неизменными, то с первым придется немного повозиться. Общий принцип создания региона - это считывание информации о каждом пикселе и включение в регион тех, которые не содержат исключаемый цвет. Давайте посмотрим как это выглядит в программе.
Примечание: Основа кодов предоставлена Иваном Шатрыкиным
Напишем отдельную функцию,
создающую регион, с исключением
заказанного, исключаемого цвета. Вначале нам понадобятся
истинные размеры картинки в пикселах. Для
этого используем объектную переменную sPic,
приравняем ее к свойству Picture текущей формы.
Правда размеры мы получим в единицах HIMETRIC,
но это легко преобразуется в пикселы с
помощью стандартных VB-функций - ScaleX и ScaleY.
Изначально создадим пустой регион. А затем,
для каждого пиксела картинки, получая их с
помощью API-функции GetPixel, устроим проверку.
Если пиксел подходит нам (т.е. не содержит
исключаемого цвета), мы включаем его в
регион.
Объявление необходимых API-функций см. в
кодах примера.
Public Function lGetRegion(frm
As Form, lBackColor As Long)
As Long
Dim lRgn As Long
Dim lSkinRgn As Long
Dim lStart As Long
Dim lX As Long
Dim lY As Long
Dim lHeight As Long
Dim lWidth As Long
Dim sPic As StdPicture
'создаем пустой регион, с которого начнем работу
lSkinRgn = CreateRectRgn(0, 0, 0, 0)
With frm
Set sPic = .Picture
'подсчитаем размеры рисунка в Pixel
lHeight = .ScaleY(sPic.Height)
lWidth = .ScaleX(sPic.Width)
For lX = 0 To lHeight - 1
lY = 0
Do While lY < lWidth
'ищем нужный Pixel
Do While lY < lWidth
And GetPixel(.hdc, lY, lX) = lBackColor
lY = lY + 1
Loop
If lY < lWidth
Then
lStart = lY
Do While lY < lWidth
And GetPixel(.hdc, lY, lX) <> lBackColor
lY = lY + 1
Loop
If lY > lWidth
Then lY = lWidth
'нужный Pixel найден, добавим его в регион
lRgn = CreateRectRgn(lStart, lX, lY, lX + 1)
CombineRgn lSkinRgn, lSkinRgn, lRgn, RGN_OR
'удалим ненужный объект
DeleteObject lRgn
End If
Loop
Next
End With
Set sPic = Nothing
lGetRegion = lSkinRgn
End Function
Создав необходимую функцию, применим ее в нашем примере. Для начала загрузим, подготовленную картинку. Затем создаем регион, вырезаем форму, и освобождаем память.
Private Sub cmdPreview_Click()
Dim hRgn As Long
With frmDemonstration
Select Case FindOptionButton
...
Case 6
Screen.MousePointer = vbHourglass
.Picture = LoadPicture(App.Path & "\Sample.bmp")
hRgn = lGetRegion(frmDemonstration, vbWhite)
Screen.MousePointer = vbDefault
...
End Select
SetWindowRgn .hwnd, hRgn, True
DeleteObject hRgn
.Show vbModal
End With
End Sub
Чем прельщает этот пример, так это
легкостью восприятия кода: считываем
пикселы и ненужные выбрасываем. Однако
здесь скрывается "маленький" недостаток - это
скорость. Если картинка маленькая, то
особых проблем не возникает. Но как только
размеры картинки начинают увеличиваться,
так катастрофически падает скорость
появления вырезанного изображения на
экране.
Как же ускорить этот процесс? Ответ
напрашивается сам собой: перенести все
расчеты региона в память. Поэтому следующий
представленный здесь вариант несколько
сложнее для восприятия, но зато и быстрее
своего предшественника минимум в 4 раза.
Почему минимум? Потому что данная
функция вынуждена учитывать цветовую
палитру Вашего экрана. Давайте
последовательно, шаг за шагом, разберем эту
функцию. Для начала нам потребуется еще
один тип, отвечающий за свойства картинки:
Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type
Так же, как и в предыдущем примере,
будем использовать объектную переменную sPic
Public Function FitToPicture(frm
As Form) As Long
...
Set sPic = frm.Picture
На следующем этапе получим информацию о картинке
в формате типа BITMAP.
GetObject sPic, Len(bm), bm
lWidth = bm.bmWidth
lHeight = bm.bmHeight
А вот теперь, исходя из полученной цветовой
палитры напишем обработку каждого пиксела:
Select Case bm.bmBitsPixel
Case равный 8 соответствует 256 цветам,
остальные - соответствующему количеству
бит. Обработка 8, 16 и 32 бит почти идентична,
за исключением типа используемых массивов
и вывода значения исключаемого цвета.
Поэтому рассмотрим подробно только один из
них на примере 16 бит.
Вначале переобъявим используемый
массив, учитывая размеры картинки и получим
это значение в битах
ReDim ints(0 To bm.bmWidthBytes \ colourDepth - 1, 0
To lHeight - 1)
GetBitmapBits sPic, lHeight * bm.bmWidthBytes, ints(0, 0)
А затем в цикле For ... Next произведем
обработку каждого пиксела. Если пиксел
удовлетворяет условиям (не является
исключаемым цветом), то он добавляется в
регион. Для ускорения обработки
используется маленький трюк: считывается и
записывается не каждый пиксел по отдельности,
а часть строки, находящаяся между двумя
пикселами исключаемого цвета. Далее этот
регион суммируется с предыдущими.
If start_c < lWidth
Then
If stop_c >= lWidth Then stop_c = lWidth - 1
new_rgn = CreateRectRgn(start_c, R, stop_c, R + 1)
If combined_rgn = 0 Then
combined_rgn = new_rgn
Else
CombineRgn combined_rgn, combined_rgn, new_rgn, RGN_OR
DeleteObject new_rgn
End If
End If
При работе с 24 битами необходимо позаботиться о смещении, для корректной обработки цвета. Но в остальном, структура функции остается та же.
Использование данной функции
в нашем примере ничем не отличается от
предыдущего варианта:
Private Sub cmdPreview_Click()
Dim hRgn As Long
With frmDemonstration
Select Case FindOptionButton
...
Case 7
Screen.MousePointer = vbHourglass
.Picture = LoadPicture(App.Path & "\Sample.bmp")
hRgn = FitToPicture(frmDemonstration)
Screen.MousePointer = vbDefault
End Select
SetWindowRgn .hwnd, hRgn, True
DeleteObject hRgn
.Show vbModal
End With
End Sub
На этом, пожалуй, можно поставить точку. Удачи Вам!
