• 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

[VB6]Tạo 1 Image trong suốt !

Các bài viết hướng dẫn, giúp các bạn hiểu và tiếp cận với Visual Basic nhanh hơn
User avatar
DQHung
Guru
Guru
Posts: 576
Joined: Mon 12/02/2007 3:24 pm
Location: Rach Gia - Kien Giang
Been thanked: 40 times
Contact:

[VB6]Tạo 1 Image trong suốt !

Postby DQHung » Thu 02/10/2008 8:48 pm

Tên bài viết: Tạo một image (giống như VB6) trong suốt
Tác giả: DQHung
Cấp độ bài viết: Normal
Tóm tắt: Image mà ta sắp tao ra có khả năng tách 1 màu ra khỏi picture (Maskcolor),làm trong suốt (alpha). alpha



Những bạn nào không muốn tìm hiểu cách viết Usercontrol thì có thể bỏ qua phần hướng dẩn và tải tập tin đính kèm về dùng.


Trước tiên ta tạo một dự án mới dạng StandardEXE, thêm vào đó 1 Usercontrol.Đặt là "Image"

Cho Backstyle của usercontrol mới tạo (mình gọi tắt là NU) bằng Transparent, ClipBehavior = 0-None và Windowless = True.Đây là việc làm đầu tiên để NU của bạn trong suốt (tùy mức độ mà ta cho) và nhìn thấy form.
Cho vào NU một Image tên là "Image1" (của VB6) dùng để load image (nhưng chủ yếu là lấy size)

Bước 2 : Copy các API sau vào NU

Code: Select all

  1. Private Declare Function SetStretchBltMode Lib "gdi32.dll" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
  2. Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
  3. Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
  4. Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
  5. Private Declare Function StretchBlt Lib "gdi32.dll" (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
  6. Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
  7. Private Declare Function GetObjectAPI Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
  8. Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
  9. Private Declare Function DrawIconEx Lib "user32" (ByVal hdc As Long, ByVal xLeft As Long, ByVal yTop As Long, ByVal hIcon As Long, ByVal cxWidth As Long, ByVal cyWidth As Long, ByVal istepIfAniCur As Long, ByVal hbrFlickerFreeDraw As Long, ByVal diFlags As Long) As Long
  10. Private Declare Function TransparentBlt Lib "msimg32.dll" (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 crTransparent As Long) As Long
  11. Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC 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 dwRop As Long) As Long
  12. Private Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
  13. Private Declare Function CreateDCAsNull Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, lpDeviceName As Any, lpOutput As Any, lpInitData As Any) As Long
  14.  
  15. Private Declare Function AlphaBlend Lib "msimg32.dll" ( _
  16.   ByVal hDCDest As Long, _
  17.   ByVal nXOriginDest As Long, _
  18.   ByVal nYOriginDest As Long, _
  19.   ByVal nWidthDest As Long, _
  20.   ByVal nHeightDest As Long, _
  21.   ByVal hDCSrc As Long, _
  22.   ByVal nXOriginSrc As Long, _
  23.   ByVal nYOriginSrc As Long, _
  24.   ByVal nWidthSrc As Long, _
  25.   ByVal nHeightSrc As Long, _
  26.   ByVal lBlendFunction As Long _
  27. ) As Long
  28.  
  29. Private Declare Function DrawState Lib "user32" Alias "DrawStateA" _
  30.     (ByVal hdc As Long, _
  31.     ByVal hBrush As Long, _
  32.     ByVal lpDrawStateProc As Long, _
  33.     ByVal lParam As Long, _
  34.     ByVal wParam As Long, _
  35.     ByVal X As Long, _
  36.     ByVal Y As Long, _
  37.     ByVal cx As Long, _
  38.     ByVal cy As Long, _
  39.     ByVal fuFlags As Long) As Long


Việc thứ 2 là code một vài property cần thiết như "Opacity" (Tính mờ-đục) , Maskcolor,USeMaskColor,Picture... Bước này bạn có thể dùng "ActiveX Control Interface Wizard..." (Nếu không rành sử dụng có thể xem lại bài viewtopic.php?f=22&t=196)

Code: Select all

  1. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  2. 'MemberInfo=7,0,0,100
  3. Public Property Get Opacity() As Integer
  4.     Opacity = m_Opacity
  5. End Property
  6.  
  7. Public Property Let Opacity(ByVal New_Opacity As Integer)
  8.     m_Opacity = New_Opacity
  9.     UserControl.Refresh
  10.     UserControl_Paint
  11.     PropertyChanged "Opacity"
  12. End Property
  13. '
  14.  
  15. 'Initialize Properties for User Control
  16. Private Sub UserControl_InitProperties()
  17.     m_Opacity = m_def_Opacity
  18.     m_UseMaskColor = m_def_UseMaskColor
  19.     m_MaskColor = m_def_MaskColor
  20.     m_AutoSize = m_def_AutoSize
  21. End Sub
  22.  
  23. 'Load property values from storage
  24. Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
  25.  
  26.     m_Opacity = PropBag.ReadProperty("Opacity", m_def_Opacity)
  27.     m_UseMaskColor = PropBag.ReadProperty("UseMaskColor", m_def_UseMaskColor)
  28.     m_MaskColor = PropBag.ReadProperty("MaskColor", m_def_MaskColor)
  29.     Set Picture = PropBag.ReadProperty("Picture", Nothing)
  30.     m_AutoSize = PropBag.ReadProperty("AutoSize", m_def_AutoSize)
  31. End Sub
  32.  
  33. 'Write property values to storage
  34. Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
  35.  
  36.     Call PropBag.WriteProperty("Opacity", m_Opacity, m_def_Opacity)
  37.     Call PropBag.WriteProperty("UseMaskColor", m_UseMaskColor, m_def_UseMaskColor)
  38.     Call PropBag.WriteProperty("MaskColor", m_MaskColor, m_def_MaskColor)
  39.     Call PropBag.WriteProperty("Picture", Picture, Nothing)
  40.     Call PropBag.WriteProperty("AutoSize", m_AutoSize, m_def_AutoSize)
  41. End Sub
  42.  
  43. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  44. 'MemberInfo=0,0,0,False
  45. Public Property Get UseMaskColor() As Boolean
  46.     UseMaskColor = m_UseMaskColor
  47. End Property
  48.  
  49. Public Property Let UseMaskColor(ByVal New_UseMaskColor As Boolean)
  50.     m_UseMaskColor = New_UseMaskColor
  51.     UserControl.Refresh
  52.     UserControl_Paint
  53.     PropertyChanged "UseMaskColor"
  54. End Property
  55.  
  56. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  57. 'MemberInfo=10,0,0,vbButtonFace
  58. Public Property Get MaskColor() As OLE_COLOR
  59.     MaskColor = m_MaskColor
  60. End Property
  61.  
  62. Public Property Let MaskColor(ByVal New_MaskColor As OLE_COLOR)
  63.     m_MaskColor = New_MaskColor
  64.     UserControl.Refresh
  65.     UserControl_Paint
  66.     PropertyChanged "MaskColor"
  67. End Property
  68.  
  69. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  70. 'MappingInfo=Image1,Image1,-1,Picture
  71. Public Property Get Picture() As Picture
  72.     Set Picture = Image1.Picture
  73. End Property
  74.  
  75. Public Property Set Picture(ByVal New_Picture As Picture)
  76.     Set Image1.Picture = New_Picture
  77.     UserControl.Refresh
  78.     UserControl_Paint
  79.     PropertyChanged "Picture"
  80. End Property
  81.  
  82. 'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!
  83. 'MemberInfo=0,0,0,False
  84. Public Property Get AutoSize() As Boolean
  85.     AutoSize = m_AutoSize
  86. End Property
  87.  
  88. Public Property Let AutoSize(ByVal New_AutoSize As Boolean)
  89.     m_AutoSize = New_AutoSize
  90.     UserControl.Refresh
  91.     UserControl_Paint
  92.     PropertyChanged "AutoSize"
  93. End Property


Và một mục rất quan trong là : HitTest, nếu bạn không code bước này thì không thể "nắm" được controls khi đã tạo trên form !

Code: Select all

  1. Private Sub UserControl_HitTest(X As Single, Y As Single, HitResult As Integer)
  2.     HitResult = vbHitResultHit
  3. End Sub
  4.  
  5. 'hàm này dùng để chuyễn Color từ OLE_COLOR sang Long
  6.  
  7. Private Function TranslateColor(ByVal clr As OLE_COLOR, _
  8.                                Optional hPal As Long = 0) As Long
  9.  
  10.     If OleTranslateColor(clr, hPal, TranslateColor) Then
  11.         TranslateColor = -1
  12.     End If
  13. End Function


Cuối dùng là Sub PAINT.Ta dùng sub này vì thuộc tính AutoRedraw của NU = False (Không tự động vẽ lại)

Code: Select all

  1. Private Sub UserControl_Paint()
  2.     Dim tmpDC As Long, tmpBitmap As Long, tmpDC2 As Long, tmpBitmap2 As Long
  3.     'tmpDC và tmpDC2 là các DeviceContext ảo dùng để lưu trử tạm thời các Image mà ta sửa
  4.     Dim SizeW As Long, SizeH As Long
  5.     '2 biến này dùng để lưu lại size của Image
  6.     On Error Resume Next
  7.  
  8.     SizeW = Image1.Width
  9.     SizeH = Image1.Height
  10.     'Lấy size của Image
  11.  
  12.     tmpDC = CreateCompatibleDC(hdc)
  13.     'Tạo DC ảo từ HandleDC của NU
  14.     tmpBitmap = CreateCompatibleBitmap(hdc, SizeW, SizeH)
  15.     'Tạo BITMAP từ HandleDC của NU
  16.     SelectObject tmpDC, tmpBitmap
  17.     'Đưa BITMAP đó vào tmpDC,không đưa vào sẻ ko vẽ đc gì cả !
  18.  
  19.     tmpDC2 = CreateCompatibleDC(hdc)
  20.     tmpBitmap2 = CreateCompatibleBitmap(hdc, SizeW, SizeH)
  21.     SelectObject tmpDC2, tmpBitmap2
  22.    
  23.     BitBlt tmpDC, 0, 0, SizeW, SizeH, hdc, 0, 0, vbSrcCopy
  24.     BitBlt tmpDC2, 0, 0, SizeW, SizeH, hdc, 0, 0, vbSrcCopy
  25.     'Ta copy vùng cần vẽ của NU lên các DC ảo
  26.  
  27.     If Image1.Picture.Type = vbPicTypeBitmap Then
  28.        DrawState tmpDC, 0, 0, Image1.Picture.Handle, 0, 0, 0, SizeW, SizeH, &H4
  29.        'Nếu là dạng Bitmap thì dùng hàm DrawState
  30.     Else
  31.        DrawIconEx tmpDC, 0, 0, Image1.Picture.Handle, SizeW, SizeH, 0, 0, &H3
  32.        'Nếu là dạng Icon hay Cursor thì dùng hàm DrawIconEx
  33.     End If
  34.  
  35.     If m_UseMaskColor Then
  36.        TransparentBlt tmpDC2, 0, 0, SizeW, SizeH, tmpDC, 0, 0, SizeW, SizeH, TranslateColor(m_MaskColor)
  37.        'Nếu sử dụng MaskColor.
  38.     Else
  39.        BitBlt tmpDC2, 0, 0, SizeW, SizeH, tmpDC, 0, 0, vbSrcCopy
  40.        'KO sử dụng MaskClor
  41.     End If
  42.    
  43.     If m_Opacity < 100 Then
  44.        AlphaBlend hdc, 0, 0, SizeW, SizeH, tmpDC2, 0, 0, SizeW, SizeH, &H0& Or (((255& * m_Opacity) \ 100&) * &H10000)
  45.        'Khi độ Opacity nhỏ hơn 100
  46.     Else
  47.        BitBlt hdc, 0, 0, SizeW, SizeH, tmpDC2, 0, 0, vbSrcCopy
  48.        'Ko có Opacity
  49.     End If
  50.    
  51.     If m_AutoSize Then
  52.        'Nếu ta đặt Autosize = True thì khi load hình sẽ tự động Fit size
  53.        Height = Image1.Height * Screen.TwipsPerPixelX
  54.        Width = Image1.Width * Screen.TwipsPerPixelY
  55.     End If
  56.     'Xóa các Bitmap và DC ảo ra khỏi bộ nhớ.
  57.  
  58.     DeleteDC tmpDC
  59.     DeleteDC tmpDC2
  60.     DeleteObject tmpBitmap
  61.     DeleteObject tmpBitmap2
  62. End Sub


Thế là xong một Image theo kiểu mới có thuộc tính Opacity,thật dể dàng phải không ? Dung lượng của file Usercontrol chưa đến 10 kb.

Và đây là source code của "Image" mà chúng ta vừa tạo ra trên.
Image.rar
Source Image alpha.
(12.24 KiB) Downloaded 1948 times


Mong bài này sẽ giúp các bạn hiểu rỏ hơn về usercontrol :) .



Return to “[VB] Bài viết hướng dẫn”

Who is online

Users browsing this forum: No registered users and 0 guests