Сжатие, изменение размеров изображений - VB
Формулировка задачи:
Всем привет!
Помогите разобраться как сжать изображение, т.е. есть рисунок безумного размера (к примеру 6000*4000 ) как его подогнать под квадратный
PictureBox
? Так же интересует выбор определенной области изображения для сохранения. А в идеале может есть специальная форма, на которую можно загрузить изображение и затем сохранить только определенную область (ну знаете как выбор аватарки в контакте: выбираешь фотку и потом перетягиваешь специальный квадратик для выбора определенной части изображения)?Решение задачи: «Сжатие, изменение размеров изображений»
textual
Листинг программы
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
ИИ поможет Вам:
- решить любую задачу по программированию
- объяснить код
- расставить комментарии в коде
- и т.д