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

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