Пишем User Control для манипуляций с изображениями на Visual Basic 6.0
Приложения, которые работают с картинками, как правило, требуют небольшого количества операций, среди которых поворот на 90 градусов, увеличение/уменьшение и перемещение. Ниже приведены этапы создания User Control’а в среде Visual Basic 6.0, в котором реализованы эти функции.
Для начала создаём новый проект, обычный Standard EXE. Этот проект и будет содержать наш контрол.
В окне Project Explorer’а нажимаем правой кнопкой мыши на нашем проекте, далее в вылезшем меню выбираем Add->User Control.
В появившемся окне выбираем User Control.
Теперь обзываем новый User Control. Пусть будет PicWork.
Добавляем на форму User Control’а необходимые стандартные элементы управления (Frame, PictureBox, CommandButton).
Затем на страницу кода пользовательского элемента управления вставляем следующий код:
Option Explicit
Private 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
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function StretchBlt Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function SetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Private pic As Picture
Private posX As Double, posY As Double, magnK As Double
Private dPosX As Double, dPosY As Double
Private mBitmap As Long, mDC As Long, bd As BITMAP
Public Sub LoadFile(fileName As String)
Set pic = LoadPicture(fileName)
mBitmap = pic.Handle
GetObject mBitmap, Len(bd), bd
SelectObject mDC, mBitmap
posX = bd.bmWidth / 2
posY = bd.bmHeight / 2
magnK = 0
Frame3.Visible = True
MagnificPicture
End Sub
Private Sub Command6_Click(Index As Integer)
Dim BytesPerLine As Long, nBytesPerLine As Long
Dim w As Long, h As Long, i As Long, t As Long, k As Long
Dim PicBits() As Byte
Dim nPicBits() As Byte
Dim bpp As Long, mBitmap3 As Long
GetObject mBitmap, Len(bd), bd
bpp = bd.bmBitsPixel / 8
BytesPerLine = bd.bmWidth * bpp
While BytesPerLine Mod 2 > 0
BytesPerLine = BytesPerLine + 1
Wend
ReDim PicBits(1 To BytesPerLine * bd.bmHeight) As Byte
GetBitmapBits mBitmap, UBound(PicBits), PicBits(1)
w = bd.bmHeight
h = bd.bmWidth
mBitmap3 = CreateCompatibleBitmap(mDC, w, h)
GetObject mBitmap3, Len(bd), bd
w = bd.bmWidth
h = bd.bmHeight
nBytesPerLine = w * bpp
While nBytesPerLine Mod 2 > 0
nBytesPerLine = nBytesPerLine + 1
Wend
ReDim nPicBits(1 To nBytesPerLine * h) As Byte
If Index = 0 Then
For t = 1 To h - 1
For i = 1 To w - 1
For k = 1 To bpp
nPicBits((h - t) * nBytesPerLine + bpp * (i - 1) + k) = PicBits((i - 1) * BytesPerLine + bpp * (t - 1) + k)
Next k
Next i
Next t
Else
For t = 1 To h - 1
For i = 1 To w - 1
For k = 1 To bpp
nPicBits((t - 1) * nBytesPerLine + bpp * (w - i) + k) = PicBits((i - 1) * BytesPerLine + bpp * (t - 1) + k)
Next k
Next i
Next t
End If
SetBitmapBits mBitmap3, UBound(nPicBits), nPicBits(1)
DeleteObject SelectObject(mDC, mBitmap3)
mBitmap = mBitmap3
MagnificPicture
End Sub
Private Sub Command7_Click()
magnK = magnK / 2
MagnificPicture
End Sub
Private Sub Command8_Click()
magnK = magnK * 2
MagnificPicture
End Sub
Private Sub MagnificPicture()
Dim cM As Double, pW As Double, pH As Double, ppW As Double, ppH As Double
Dim dWl As Double, dWr As Double, dHu As Double, dHd As Double
Dim ddWl As Double, ddWr As Double, ddHu As Double, ddHd As Double
Dim nW As Double, nH As Double
On Error Resume Next
nW = Frame1.Width - 200
nH = Frame1.Height - 900
pW = nW / Screen.TwipsPerPixelX
pH = nH / Screen.TwipsPerPixelY
'Выбираем по какому измерению масштабируем
cM = pW / bd.bmWidth
If cM > pH / bd.bmHeight Then
cM = pH / bd.bmHeight
End If
'Смотрим не уменьшили ли слишком сильно
If cM > magnK Then
magnK = cM
End If
'Нормируем размер картинки
If nW > bd.bmWidth * magnK * Screen.TwipsPerPixelX Then nW = bd.bmWidth * magnK * Screen.TwipsPerPixelX
If nH > bd.bmHeight * magnK * Screen.TwipsPerPixelY Then nH = bd.bmHeight * magnK * Screen.TwipsPerPixelY
Pict.Width = nW
Pict.Height = nH
DoEvents
'Центрируем
If posX + pW / 2 / magnK > bd.bmWidth Then
posX = -pW / 2 / magnK + bd.bmWidth
End If
If posX - pW / 2 / magnK < 0 Then
posX = pW / 2 / magnK
End If
If posY + pH / 2 / magnK > bd.bmHeight Then
posY = -pH / 2 / magnK + bd.bmHeight
End If
If posY - pH / 2 / magnK < 0 Then
posY = pH / 2 / magnK
End If
'Исходное изображение
ddWl = posX - pW / 2 / magnK
ddWr = posX + pW / 2 / magnK
ddHu = posY - pH / 2 / magnK
ddHd = posY + pH / 2 / magnK
StretchBlt Pict.hdc, 0, 0, pW, pH, mDC, ddWl, ddHu, ddWr - ddWl, ddHd - ddHu, vbSrcCopy
End Sub
Private Sub Pict_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
dPosX = X
dPosY = Y
End Sub
Private Sub Pict_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
If Button = vbLeftButton Then
posX = posX - (X - dPosX) / Screen.TwipsPerPixelX / magnK
posY = posY - (Y - dPosY) / Screen.TwipsPerPixelY / magnK
dPosX = X
dPosY = Y
MagnificPicture
End If
End Sub
Private Sub UserControl_Initialize()
mDC = CreateCompatibleDC(Pict.hdc)
End Sub
Private Sub UserControl_Paint()
MagnificPicture
End Sub
Private Sub UserControl_Resize()
If UserControl.Width < 4000 Or UserControl.Height < 4000 Then Exit Sub
Frame1.Width = UserControl.Width
Frame1.Height = UserControl.Height
Frame3.Top = Frame1.Height - Frame3.Height - 100
MagnificPicture
End Sub
Private Sub UserControl_Terminate()
DeleteObject mBitmap
DeleteObject mDC
End Sub
Теперь вставляем новый User Control на основную форму приложения. А на страницу кода этой форму следующий код:
Option Explicit
Private Sub Form_Load()
PicWork1.LoadFile (App.Path & "\test.jpg")
End Sub
Private Sub Form_Resize()
PicWork1.Width = Me.Width - 200
PicWork1.Height = Me.Height - 1000
End Sub
Теперь, главное, чтобы в папке с программой оказался файл “test.jpg”. Кроме того, при увеличении картинки, если она не влезает в отведённый ей PictureBox, её можно подвигать. Для этого в произвольном месте картинки нажимаем левую кнопку мыши и перемещая мышку, не отпуская левой кнопки, мы передвигаемся по картинке.
Коротаевский Андрей