MyTetra Share
Делитесь знаниями!
Сжатие, изменение размеров изображений - VB
Время создания: 24.03.2018 23:27
Раздел: VB
Запись: xintrea/mytetra_db_adgaver_new/master/base/1521923271sbfqr60aay/text.html на raw.githubusercontent.com

Сжатие, изменение размеров изображений - VB

Всем привет! Помогите разобраться как сжать изображение, т.е. есть рисунок безумного размера (к примеру 6000*4000 ) как его подогнать под квадратный PictureBox ? Так же интересует выбор определенной области изображения для сохранения. А в идеале может есть специальная форма, на которую можно загрузить изображение и затем сохранить только определенную область (ну знаете как выбор аватарки в контакте: выбираешь фотку и потом перетягиваешь специальный квадратик для выбора определенной части изображения)?


Option Explicit

 

Private Type GUID

    Data1 As Long

    Data2 As Integer

    Data3 As Integer

    Data4(7) As Byte

End Type


Private Type PicBmp

    size As Long

    Type As Long

    hBmp As Long

    hpal As Long

    Reserved As Long

End Type


Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long

Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long

Private Declare Function DeleteDC Lib "gdi32" (ByVal hdc 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 Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (PicDesc As PicBmp, RefIID As GUID, ByVal fPictureOwnsHandle As Long, IPic As IPicture) As Long

 

Public Function Conv(hBmp As Long) As StdPicture

    Dim Pic As PicBmp

    Dim IID_IDispatch As GUID

    With IID_IDispatch

       .Data1 = &H20400

       .Data4(0) = &HC0

       .Data4(7) = &H46

    End With

    With Pic

       .size = Len(Pic)

       .Type = vbPicTypeBitmap

       .hBmp = hBmp

    End With

    OleCreatePictureIndirect Pic, IID_IDispatch, 1, Conv

End Function


Private Sub imgPic_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim d As Single, w As Long, h As Long, ohBmp As Long, hBmp As Long, DC As Long, p As IPicture

    If Button = vbLeftButton Then d = 1.5 Else d = 0.66

        w = ScaleX(imgPic.Picture.Width, vbHimetric, vbPixels) * d

        h = ScaleY(imgPic.Picture.Height, vbHimetric, vbPixels) * d

        If w > 0 And h > 0 Then

        imgPic.Width = w: imgPic.Height = h

        DC = CreateCompatibleDC(Me.hdc)

        hBmp = CreateCompatibleBitmap(Me.hdc, w, h)

        ohBmp = SelectObject(DC, hBmp)

        Set p = imgPic.Picture

        p.Render DC, 0, 0, w, h, 0, imgPic.Picture.Height, imgPic.Picture.Width, -imgPic.Picture.Height, ByVal 0

        SelectObject DC, ohBmp

        DeleteDC DC

        Set imgPic.Picture = Conv(hBmp)

        Me.Width = (Me.Width / Screen.TwipsPerPixelX - Me.ScaleWidth + w + imgPic.Left * 2) * Screen.TwipsPerPixelX

        Me.Height = (Me.Height / Screen.TwipsPerPixelY - Me.ScaleHeight + h + imgPic.Top * 2) * Screen.TwipsPerPixelY

    End If

End Sub

Так же в этом разделе:
 
MyTetra Share v.0.59
Яндекс индекс цитирования