• Vui lòng đọc nội qui diễn đàn để tránh bị xóa bài viết
  • Tìm kiếm trước khi đặt câu hỏi

Resize Picture - Tùy chỉnh kích thước

Các thủ thuật về âm thanh, đồ họa, truyền thông đa phương tiện...
Hình đại diện của người dùng
clarkkent
Mạnh Thường Quân
Mạnh Thường Quân
Bài viết: 1641
Ngày tham gia: T.Tư 16/04/2008 11:25 am
Đến từ: Chợ Lách - Bến Tre
Been thanked: 31 time
Liên hệ:

Resize Picture - Tùy chỉnh kích thước

Gửi bàigửi bởi clarkkent » T.Tư 03/06/2009 1:43 pm

Thủ thuật: Resize Picture - Tùy chỉnh kích thước
Tác giả: Sưu tầm
Mô tả: Resize Picture - Tùy chỉnh kích thước



module

Mã: Chọn hết

  1. Option Explicit
  2.  
  3. Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
  4. Private Declare Function CreateBitmap Lib "gdi32.dll" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, ByRef lpBits As Any) As Long
  5. Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
  6. Private Declare Function GetObject Lib "gdi32.dll" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, ByRef lpObject As Any) As Long
  7. Private Type BITMAP
  8.     bmType As Long
  9.     bmWidth As Long
  10.     bmHeight As Long
  11.     bmWidthBytes As Long
  12.     bmPlanes As Integer
  13.     bmBitsPixel As Integer
  14.     bmBits As Long
  15. End Type
  16.  
  17. Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As PictDesc, riid As Guid, ByVal fPictureOwnsHandle As Long, iPic As StdPicture) As Long
  18. Private Type PictDesc
  19.     cbSizeofStruct As Long
  20.     picType As Long
  21.     hImage As Long
  22.     xExt As Long
  23.     yExt As Long
  24. End Type
  25.  
  26. Private Type Guid
  27.     Data1 As Long
  28.     Data2 As Integer
  29.     Data3 As Integer
  30.     Data4(0 To 7) As Byte
  31. End Type
  32.  
  33. Private Type RGBtype
  34.     B As Byte
  35.     R As Byte
  36.     G As Byte
  37. End Type
  38.  
  39. Private Declare Function GetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
  40. Private Declare Function SetDIBits Lib "gdi32" (ByVal hdc As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, lpBits As Any, lpBI As BITMAPINFO, ByVal wUsage As Long) As Long
  41.  
  42. Private Const DIB_RGB_COLORS = 0&
  43. Public Const BI_RGB = 0&
  44.  
  45. Type BITMAPINFOHEADER
  46.    biSize As Long
  47.    biWidth As Long
  48.    biHeight As Long
  49.    biPlanes As Integer
  50.    biBitCount As Integer
  51.    biCompression As Long
  52.    biSizeImage As Long
  53.    biXPelsPerMeter As Long
  54.    biYPelsPerMeter As Long
  55.    biClrUsed As Long
  56.    biClrImportant As Long
  57. End Type
  58.  
  59. Type RGBQUAD
  60.    rgbBlue As Byte
  61.    rgbGreen As Byte
  62.    rgbRed As Byte
  63.    rgbReserved As Byte
  64. End Type
  65.  
  66. Type BITMAPINFO
  67.   bmiHeader As BITMAPINFOHEADER
  68.   bmiColors As RGBQUAD
  69. End Type
  70.  
  71. '*****************************************************
  72. 'PowerResize
  73. ' Returns a resized version of Img with the new dimensions passed.
  74. '
  75. 'Written by Mark Gordon aka msg555
  76. '1/16/06
  77. 'Free to use/sell/whatever
  78. '*****************************************************
  79. Public Function PowerResize(Img As StdPicture, newWidth As Long, newHeight As Long) As StdPicture
  80.     Debug.Assert Img.Type = vbPicTypeBitmap 'Image must be a bitmap
  81.        
  82.     Dim SrcBmp As BITMAP
  83.     GetObject Img.handle, Len(SrcBmp), SrcBmp
  84.        
  85.     Dim srcBI As BITMAPINFO
  86.     With srcBI.bmiHeader
  87.         .biSize = Len(srcBI.bmiHeader)
  88.         .biWidth = SrcBmp.bmWidth
  89.         .biHeight = -SrcBmp.bmHeight
  90.         .biPlanes = 1
  91.         .biBitCount = 32
  92.         .biCompression = BI_RGB
  93.     End With
  94.  
  95.     'Create Source Bit Array
  96.     Dim SrcBits() As RGBQUAD
  97.     ReDim SrcBits(0 To SrcBmp.bmWidth - 1, 0 To SrcBmp.bmHeight - 1) As RGBQUAD
  98.  
  99.     'Grab Source Bits
  100.     Dim lDc As Long
  101.     lDc = CreateCompatibleDC(0)
  102.     GetDIBits lDc, Img.handle, 0, SrcBmp.bmHeight, SrcBits(0, 0), srcBI, DIB_RGB_COLORS
  103.     DeleteDC lDc
  104.  
  105.     'Create Destination Bit Array
  106.     Dim DblDstBits() As Double
  107.     ReDim DblDstBits(0 To 3, 0 To newWidth - 1, 0 To newHeight - 1) As Double
  108.  
  109.     'Multipliers
  110.     Dim xMult As Double, yMult As Double
  111.     xMult = newWidth / SrcBmp.bmWidth
  112.     yMult = newHeight / SrcBmp.bmHeight
  113.  
  114.     'Traversing variables
  115.     Dim X As Long, XX As Long
  116.     Dim Y As Long, YY As Long
  117.    
  118.     'Low/High scan X/Y
  119.     Dim lsX As Double, hsX As Double
  120.     Dim lsY As Double, hsY As Double
  121.    
  122.     Dim OverlapWidth As Double
  123.     Dim OverlapHeight As Double
  124.     Dim Overlap As Double
  125.    
  126.     For X = 0 To SrcBmp.bmWidth - 1
  127.         lsX = X * xMult
  128.         hsX = X * xMult + xMult
  129.         For Y = 0 To SrcBmp.bmHeight - 1
  130.             lsY = Y * yMult
  131.             hsY = Y * yMult + yMult
  132.             For XX = Fix(lsX) To IIf(Fix(hsX) = hsX, Fix(hsX), Fix(hsX + 1)) - 1
  133.                 For YY = Fix(lsY) To IIf(Fix(hsY) = hsY, Fix(hsY), Fix(hsY + 1)) - 1
  134.                     OverlapWidth = 1
  135.                     OverlapHeight = 1
  136.                    
  137.                     If XX < lsX Then OverlapWidth = 1# - (lsX - XX)
  138.                     If XX + 1# > hsX Then OverlapWidth = OverlapWidth - (XX + 1# - hsX)
  139.                     If YY < lsY Then OverlapHeight = 1# - (lsY - YY)
  140.                     If YY + 1# > hsY Then OverlapHeight = OverlapHeight - (YY + 1# - hsY)
  141.                    
  142.                     Overlap = OverlapHeight * OverlapWidth
  143.                    
  144.                     DblDstBits(0, XX, YY) = DblDstBits(0, XX, YY) + SrcBits(X, Y).rgbRed * Overlap
  145.                     DblDstBits(1, XX, YY) = DblDstBits(1, XX, YY) + SrcBits(X, Y).rgbGreen * Overlap
  146.                     DblDstBits(2, XX, YY) = DblDstBits(2, XX, YY) + SrcBits(X, Y).rgbBlue * Overlap
  147.                     DblDstBits(3, XX, YY) = DblDstBits(3, XX, YY) + Overlap
  148.                 Next
  149.             Next
  150.         Next
  151.     Next
  152.    
  153.     Dim DstBits() As RGBQUAD
  154.     ReDim DstBits(0 To newWidth - 1, 0 To newHeight - 1) As RGBQUAD
  155.    
  156.     For X = 0 To newWidth - 1
  157.         For Y = 0 To newHeight - 1
  158.             DstBits(X, Y).rgbRed = Round(DblDstBits(0, X, Y) / DblDstBits(3, X, Y))
  159.             DstBits(X, Y).rgbGreen = Round(DblDstBits(1, X, Y) / DblDstBits(3, X, Y))
  160.             DstBits(X, Y).rgbBlue = Round(DblDstBits(2, X, Y) / DblDstBits(3, X, Y))
  161.         Next
  162.     Next
  163.    
  164.     Dim dstBI As BITMAPINFO
  165.     With dstBI.bmiHeader
  166.         .biSize = Len(dstBI.bmiHeader)
  167.         .biWidth = newWidth
  168.         .biHeight = -newHeight
  169.         .biPlanes = 1
  170.         .biBitCount = 32
  171.         .biCompression = BI_RGB
  172.     End With
  173.    
  174.     Dim hBmp As Long
  175.     hBmp = CreateBitmap(newWidth, newHeight, 1, 32, ByVal 0)
  176.  
  177.     SetDIBits 0, hBmp, 0, newHeight, DstBits(0, 0), dstBI, DIB_RGB_COLORS
  178.  
  179.     Dim IGuid As Guid
  180.     With IGuid
  181.         .Data1 = &H7BF80980
  182.         .Data2 = &HBF32
  183.         .Data3 = &H101A
  184.         .Data4(0) = &H8B
  185.         .Data4(1) = &HBB
  186.         .Data4(2) = &H0
  187.         .Data4(3) = &HAA
  188.         .Data4(4) = &H0
  189.         .Data4(5) = &H30
  190.         .Data4(6) = &HC
  191.         .Data4(7) = &HAB
  192.     End With
  193.    
  194.     Dim PicDst As PictDesc
  195.     With PicDst
  196.         .cbSizeofStruct = Len(PicDst)
  197.         .hImage = hBmp
  198.         .picType = vbPicTypeBitmap
  199.     End With
  200.    
  201.     OleCreatePictureIndirect PicDst, IGuid, True, PowerResize
  202. End Function


ví dụ

Mã: Chọn hết

  1. Private Sub Command1_Click()
  2. Picture2.Picture = PowerResize(Picture1.Picture, 200, 200) 'tùy chỉnh kích thước
  3. End Sub


• Hôm bây: www.tinsoftware.com ^ ^
Cố gắng lên...

Hình đại diện của người dùng
andylam1992
Thành viên danh dự
Thành viên danh dự
Bài viết: 380
Ngày tham gia: T.Hai 06/04/2009 12:57 pm
Đến từ: TP.HCM Q5
Has thanked: 2 time
Been thanked: 4 time
Liên hệ:

Re: Resize Picture - Tùy chỉnh kích thước

Gửi bàigửi bởi andylam1992 » T.Tư 10/06/2009 8:48 pm

Resize này có làm bể ảnh không vậy anh?

不相信未作牺牲竟先可拥有
只相信是靠双手找到我欲求
Cần - Kiệm- Liêm(liêm kiết) - Nghĩa - Chí - Tín

Hình đại diện của người dùng
clarkkent
Mạnh Thường Quân
Mạnh Thường Quân
Bài viết: 1641
Ngày tham gia: T.Tư 16/04/2008 11:25 am
Đến từ: Chợ Lách - Bến Tre
Been thanked: 31 time
Liên hệ:

Re: Resize Picture - Tùy chỉnh kích thước

Gửi bàigửi bởi clarkkent » T.Tư 10/06/2009 9:33 pm

andylam1992 đã viết:Resize này có làm bể ảnh không vậy anh?

nếu thu nhỏ lại thì ko, phóng to mới bị
• Hôm bây: www.tinsoftware.com ^ ^
Cố gắng lên...

moitoe
Thành viên chính thức
Thành viên chính thức
Bài viết: 19
Ngày tham gia: T.Sáu 11/12/2009 10:01 pm

Re: Resize Picture - Tùy chỉnh kích thước

Gửi bàigửi bởi moitoe » T.Hai 14/12/2009 5:55 pm

code của bác clarkkent sư tầm không chạy, bị báo lỗi "Public Const BI_RGB = 0&". Bác nào sửa giúp cái.

Hình đại diện của người dùng
thuannv
Guru
Guru
Bài viết: 69
Ngày tham gia: T.Bảy 18/11/2006 12:47 pm
Đến từ: Việt Nam quê hương tôi
Liên hệ:

Re: Resize Picture - Tùy chỉnh kích thước

Gửi bàigửi bởi thuannv » T.Năm 17/02/2011 2:21 pm

Chắc là bạn để code vào form. Bạn tạo 1 module đưa code trên vào.
Lòng khoan dung là mức độ cao nhất của sức mạnh
Ý muốn trả thù là biểu hiện đầu tiên của sự yếu đuối.

qhhqnavy
Thành viên tích cực
Thành viên tích cực
Bài viết: 102
Ngày tham gia: T.Bảy 26/02/2011 10:45 am
Đến từ: Hải Phòng City

Re: Resize Picture - Tùy chỉnh kích thước

Gửi bàigửi bởi qhhqnavy » T.Ba 05/04/2011 9:28 am

thanks..................


Quay về “[VB] Âm thanh và Đồ họa”

Đang trực tuyến

Đang xem chuyên mục này: Không có thành viên nào trực tuyến.1 khách