Пишем 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, её можно подвигать. Для этого в произвольном месте картинки нажимаем левую кнопку мыши и перемещая мышку, не отпуская левой кнопки, мы передвигаемся по картинке.

 

 

Коротаевский Андрей 








Rambler's Top100 Рейтинг@Mail.ru

mdls.ru © 2008-2013

НОВОСТИ
03.04.2014
Проект "ЧПУ на Ардуино" перенесён на ecnc.ru
Открытый проект "Простой станок с ЧПУ на Ардуино" перенесён на http://ecnc.ru
25.01.2013
Опубликован сайт "Частный переводчик"
Частный переводчик поможет провести переговоры, осуществит последовательный, синхронный, письменный переводы. http://tran.mdls.ru
25.01.2013
Начата раработка открытого проекта "Станок с ЧПУ"
Как сделать простой станок с ЧПУ на базе Arduino стоимостью менее 100$ своими руками. http://cnc.mdls.ru.
25.10.2011
"Юристы помогают" перенесён на lawshelp.ru
Проведена смена домена urist.mdls.ru на lawshelp.ru. Теперь обсудить задачи из любых отраслей Права можно на сайте www.lawshelp.ru