| |
Данный пример покажет, как можно создать образ (mask image) картинки. Образы маски полезны для эмуляции прозрачности, и для замены цветов в изображениях.
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long)
As Long
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 DeleteObject Lib "gdi32" (ByVal hObject As Long) As
Long
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
Private Const SRCCOPY = &HCC0020
Private Declare Function SetBkColor Lib "gdi32" (ByVal hDC As Long, ByVal
crColor As Long) As Long
Public Function CreateMaskImage(ByRef picFrom As PictureBox, ByRef picTo As PictureBox,
Optional ByVal lTransparentColor As Long = -1) As Boolean
Dim lhDC As Long
Dim lhBmp As Long
Dim lhBmpOld As Long
' Make picTo the same size as picFrom and clear it:
With picTo
.Width = picFrom.Width
.Height = picFrom.Height
.Cls
End With
' Create a monochrome DC & Bitmap of the same size as the source picture:
lhDC = CreateCompatibleDC(0)
If (lhDC <> 0) Then
lhBmp = CreateCompatibleBitmap(lhDC, picFrom.ScaleWidth \ Screen.TwipsPerPixelX,
picFrom.ScaleHeight \ Screen.TwipsPerPixelY)
If (lhBmp <> 0) Then
lhBmpOld = SelectObject(lhDC, lhBmp)
' Set the back 'colour' of the monochrome DC to the colour we wish to be transparent:
If (lTransparentColor = -1) Then lTransparentColor = picFrom.BackColor
SetBkColor lhDC, lTransparentColor
' Copy from the from picture to the monochrome DC to create the mask:
BitBlt lhDC, 0, 0, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \
Screen.TwipsPerPixelY, picFrom.hDC, 0, 0, SRCCOPY
' Now put the mask into picTo:
BitBlt picTo.hDC, 0, 0, picFrom.ScaleWidth \ Screen.TwipsPerPixelX, picFrom.ScaleHeight \
Screen.TwipsPerPixelY, lhDC, 0, 0, SRCCOPY
picTo.Refresh
' Clear up the bitmap we used to create the mask:
SelectObject lhDC, lhBmpOld
DeleteObject lhBmp
End If
' Clear up the monochrome DC:
DeleteObject lhDC
End If
End Function
Private Sub Command1_Click()
CreateMaskImage Picture1, Picture2
End Sub
Private Sub Form_Load()
Dim i As Long
Picture1.BackColor = &HFFFF00
With Picture1.Font
.Name = "Arial"
.Bold = True
.Italic = True
.Size = 12
End With
For i = 1 To 20
Picture1.ForeColor = QBColor(i Mod 15)
Picture1.Print "vbAccelerator Mask Demo"
Next i
End Sub
|
|