Visual Basic - Mascaras

Pregunta: Como crear una mascara de sombra de una imagen usando
las API's de Windows (lei un ejemplo en un libro llamado "Programación
Avansada con Visual Basic)
porfa ejemplos se que tiene que ver con crear un handle para una imagen monocroma (para VB6 )

Pocho:
Ese libro trae un CD con los ejemplos hechos. Ahí está. También podés buscar en el MSDN (Ayuda de Visual Studio) o en http://www.microsoft.com/spanish/msdn/argentina/

Saludos Ruri

Pocho:
Supongo que lo que querés es dibujar una imagen con fondo transparente. NO es difícil, se utiliza Transparentblt, tiene los mismos argumentos que StretchBlt, salvo el último que indica el color y no la forma como se pinta. El inconveniente es que sólo funciona en Windows 2000, XP y 2003. Pero siempre se puede volver a hacer las cosas al viejo estilo y utilizar una máscara monocroma para crear un agujero sobre el que pintar. Desde hace mucho tiempo terngo un módulo que hace algo de pintura avanzada, allí está TransparentBltEX, es una envolvente de TransparentBlt que funciona en todas las plataformas. Si estás en w2k wxp o w2k3 llama a transparentblt, si falla hace las cosas al viejo estilo. El módulo trae algunas utilidades más para usa con GDI, la mayoría las saque hace mucho del MSDN y les hice algunos ajustes con el tiempo (por ejemplo a TransparentBltEx, le agregé TransparentBlt y le cambié el nombre). Exploralas y utilizalas todo lo que quieras. Todas te sirven como ejemplo para usar la GDI. Si podés mejorarlas avisame.
En los siguientes mails, te mando las partes del módulo, primero las declaraciones y luego el resto, pegalo todo junto en un módulo y listo. Si no te das cuenta como usarlas me escribís y listo

Option Explicit
DefLng A-Z

Public Type POINTAPI
X As Long
Y As Long
End Type

Public Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type

Public Type Size
Cx As Long
Cy As Long
End Type

Public Type DRAWTEXTPARAMS
cbSize As Long
iTabLength As Long
iLeftMargin As Long
iRightMargin As Long
uiLengthDrawn As Long
End Type

Private Type OSVERSIONINFO
dwOSVersionInfoSize As Long
dwMajorVersion As Long
dwMinorVersion As Long
dwBuildNumber As Long
dwPlatformId As Long
szCSDVersion As String * 128 ' Cadena de mantenimiento para uso de PSS
End Type

Public Const AC_SRC_OVER = &H0

Public Type BLENDFUNCTION
BlendOp As Byte
BlendFlags As Byte
SourceConstantAlpha As Byte
AlphaFormat As Byte
End Type

Public Declare Function AlphaBlend Lib "msimg32.dll" (ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal WidthDest As Long, ByVal HeightDest As Long, ByVal hdcSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, ByVal WidthSrc As Long, ByVal HeightSrc As Long, ByVal BLENDFUNCT As Long) As Long

Public Type BITMAPINFOHEADER '40 bytes
biSize As Long
biWidth As Long
biHeight As Long
biPlanes As Integer
biBitCount As Integer
biCompression As Long
biSizeImage As Long
biXPelsPerMeter As Long
biYPelsPerMeter As Long
biClrUsed As Long
biClrImportant As Long
End Type

Public Type RGBQUAD
rgbBlue As Byte
rgbGreen As Byte
rgbRed As Byte
rgbReserved As Byte
End Type

Public Type BITMAPINFO
bmiHeader As BITMAPINFOHEADER
bmiColors(1) As RGBQUAD
End Type

Private Type TPictDesc
cbSizeofStruct As Long
picType As Long
hImage As Long ' hBitmap, hIcon, or hMetafile
xExt As Long ' hPal for bitmap
yExt As Long
End Type

Private Type TGuid
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(0 To 7) As Byte
End Type

Public Type IconInfo
fIcon As Long
xHotspot As Long
yHotspot As Long
hbmMask As Long
hbmColor As Long
End Type

'Public Const STRETCH_ORSCANS = 2
Public Const HALFTONE = 4

Public Const STRETCH_DELETESCANS As Long = 3
Public Const DI_NORMAL As Long = &H3
Public Const rHMPX As Single = 1000 / 567
'Public Const STRETCH_HALFTONE As Long = 4
'Public Const AC_SRC_OVER As Long = &H0
'Public Const IMAGE_BITMAP As Long = 0
'Public Const LR_LOADFROMFILE As Long = &H10

'Public Type BLENDFUNCTION
' BlendOp As Byte
' BlendFlags As Byte
' SourceConstantAlpha As Byte
' AlphaFormat As Byte
'End Type

Public Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Integer
bmBitsPixel As Integer
bmBits As Long
End Type

'Public Type Size
' cx As Long
' cy As Long
'End Type

'Public Type POINTAPI
' X As Long
' Y As Long
'End Type

Public Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
'Iconos, bitmaps (loadimage, drawicon, etc.)
'Public Const DI_NORMAL As Long = &H3
Public Const DI_DEFAULTSIZE As Long = &H8
Public Const IMAGE_ICON = 1
Public Const IMAGE_CURSOR = 2
Public Const LR_DEFAULTCOLOR = &H0
Public Const LR_DEFAULTSIZE = &H40
Public Const LR_SHARED = &H8000&

Public Const LOGPIXELSY = 90
Public Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Public Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Public Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function ReleaseDC Lib "user32" (ByVal hwnd As Long, ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function DeleteDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hdc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Public Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Public Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Public Declare Function SaveDC Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function RestoreDC Lib "gdi32" (ByVal hdc As Long, ByVal nSavedDC As Long) As Long
Public Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Public Declare Function CreateSolidBrush Lib "gdi32" (ByVal crColor As Long) As Long
Public Declare Function GetBitmap Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As BITMAP) As Long
Public Declare Function FillRect Lib "user32" (ByVal hdc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
'Private Declare Function AngleArc Lib "gdi32" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal dwRadius As Long, ByVal eStartAngle As Single, ByVal eSweepAngle As Single) As Long
Public Declare Function LoadBitmapBynum& Lib "user32" Alias "LoadBitmapA" (ByVal hInstance As Long, ByVal lpBitmapName As Long)
Public Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long

Public Declare Function SetBkMode Lib "gdi32" (ByVal hdc As Long, ByVal nBkMode As Long) As Long
Public Declare Function GetBkMode Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function GetBkColor Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SetStretchBltMode Lib "gdi32" (ByVal hdc As Long, ByVal nStretchMode As Long) As Long
Public Declare Function GetIconInfo Lib "user32" (ByVal hIcon As Long, piconinfo As IconInfo) As Long
Public 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
Public Declare Function StretchBlt Lib "gdi32" (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
Public 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
Public Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Public Declare Function GetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long) As Long
Public 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
Public Declare Function SetMapMode Lib "gdi32" (ByVal hdc As Long, ByVal nMapMode As Long) As Long
Public Const MM_ANISOTROPIC = 8
Public Declare Function SetViewportExtEx Lib "gdi32" (ByVal hdc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As Size) As Long
Public Declare Function GetViewportExtEx Lib "gdi32" (ByVal hdc As Long, lpSize As Size) As Long
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (lpPictDesc As TPictDesc, riid As TGuid, ByVal fPictureOwnsHandle As Long, ipic As IPicture) As Long
Private Declare Function DestroyIcon Lib "user32" (ByVal hIcon As Long) As Long

Private Declare Function DestroyBitmap Lib "gdi32" Alias "DeleteObject" (ByVal hObject As Long) As Long
Public Declare Function DrawIcon Lib "user32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal hIcon As Long) As Long
Public Declare Function GetTextColor Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SelectPalette Lib "gdi32" (ByVal hdc As Long, ByVal hPalette As Long, ByVal bForceBackground As Long) As Long
Public Declare Function RealizePalette Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function CreateHalftonePalette Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function OleTranslateColor Lib "oleaut32.dll" (ByVal lOleColor As Long, ByVal lHPalette As Long, lColorRef As Long) As Long
Public Declare Function CreateDIBSection Lib "gdi32" (ByVal hdc As Long, pBitmapInfo As BITMAPINFO, ByVal un As Long, ByVal lplpVoid As Long, ByVal handle As Long, ByVal dw As Long) As Long
Public Declare Function SetDIBColorTable Lib "gdi32" (ByVal hdc As Long, ByVal un1 As Long, ByVal un2 As Long, pcRGBQuad As RGBQUAD) As Long
Public Declare Function GetMapMode Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Function SetPixel Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long) As Long
Public Declare Function GetStretchBltMode Lib "gdi32" (ByVal hdc As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function DrawTextEx Lib "user32" Alias "DrawTextExA" (ByVal hdc As Long, ByVal lpsz As String, ByVal N As Long, lpRect As RECT, ByVal un As Long, ByRef lpDrawTextParams As DRAWTEXTPARAMS) As Long 'DRAWTEXTPARAMS
Public Declare Function GetWindowDC Lib "user32" (ByVal hwnd As Long) As Long
Public Declare Function GetTextExtentPoint32 Lib "gdi32" Alias "GetTextExtentPoint32A" (ByVal hdc As Long, ByVal lpsz As String, ByVal cbString As Long, lpSize As Size) As Long
Public Declare Sub GetComponentsColor2 Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GdiGetBatchLimit Lib "gdi32" () As Long
Public Declare Function GdiSetBatchLimit Lib "gdi32" (ByVal dwLimit As Long) As Long
Public Declare Function ExtFloodFill Lib "gdi32" (ByVal hdc As Long, ByVal X As Long, ByVal Y As Long, ByVal crColor As Long, ByVal wFillType As Long) As Long

Public Const DT_MODIFYSTRING As Long = &H10000
'DrawIconEx Flags
Public Const DI_MASK = &H1
Public Const DI_IMAGE = &H2
'Public Const DI_NORMAL = &H3
Public Const DI_COMPAT = &H4
'Public Const DI_DEFAULTSIZE = &H8

'DIB Section constants
Public Const BI_RGB = 0&
Public Const DIB_RGB_COLORS = 0 ' color table in RGBs

'Raster Operation Codes
Public Const DSna = &H220326 '0x00220326

'VB Errors
Public Const giINVALID_PICTURE As Integer = 481
'Draw state
Public Const DST_BITMAP = &H4
Public Const DST_ICON = &H3

'Pinta un DC con aspecto deshabilitado
Public Sub PaintDisabledDC(ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal Width As Long, _
ByVal Height As Long, ByVal hdcSrc As Long, Optional ByVal XSrc As Long = 0, Optional ByVal YSrc As Long = 0, _
Optional ByVal clrMask As OLE_COLOR = vbWhite, Optional ByVal clrHighlight As OLE_COLOR = vb3DHighlight, _
Optional ByVal clrShadow As OLE_COLOR = vb3DShadow, Optional ByVal hPal As Long = 0)

Dim hdcScreen As Long, hbmMonoSection As Long, hbmMonoSectionSav As Long, hdcMonoSection As Long, hdcColor As Long
Dim hdcDisabled As Long, hbmDisabledSav As Long, lpbi As BITMAPINFO, hbmMono As Long, hdcMono As Long, hbmMonoSav As Long
Dim lMaskColor As Long, lMaskColorCompare As Long, hdcMaskedSource As Long, hbmMasked As Long, hbmMaskedOld As Long
Dim hpalMaskedOld As Long, hpalDisabledOld As Long, hpalMonoOld As Long, rgbBlack As RGBQUAD, rgbWhite As RGBQUAD
Dim dwSys3dShadow As Long, dwSys3dHighlight As Long, pvBits As Long, rgbnew(1) As RGBQUAD, hbmDisabled As Long
Dim lMonoBkGrnd As Long, lMonoBkGrndChoices(2) As Long, lIndex As Long 'For ... Next index
Dim hbrWhite As Long, udtRect As RECT

'TODO: handle pictures with dark masks
'If hPal = 0 Then
' hPal = m_hpalHalftone
'End If
' Define some colors
OleTranslateColor clrShadow, hPal, dwSys3dShadow
OleTranslateColor clrHighlight, hPal, dwSys3dHighlight

hdcScreen = GetDC(0&)
With rgbBlack
.rgbBlue = 0
.rgbGreen = 0
.rgbRed = 0
.rgbReserved = 0
End With
With rgbWhite
.rgbBlue = 255
.rgbGreen = 255
.rgbRed = 255
.rgbReserved = 255
End With

' The first step is to create a monochrome bitmap with two colors:
' white where colors in the original are light, and black
' where the original is dark. We can't simply bitblt to a bitmap.
' Instead, we create a monochrome (bichrome?) DIB section and bitblt
' to that. Windows will do the conversion automatically based on the
' DIB section's palette. (I.e. using a DIB section, Windows knows how
' to map "light" colors and "dark" colors to white/black, respectively.
With lpbi.bmiHeader
.biSize = LenB(lpbi.bmiHeader)
.biWidth = Width
.biHeight = -Height
.biPlanes = 1
.biBitCount = 1 ' monochrome
.biCompression = BI_RGB
.biSizeImage = 0
.biXPelsPerMeter = 0
.biYPelsPerMeter = 0
.biClrUsed = 0 ' max colors used (2^1 = 2)
.biClrImportant = 0 ' all (both :-]) colors are important
End With
With lpbi
.bmiColors(0) = rgbBlack
.bmiColors(1) = rgbWhite
End With

hbmMonoSection = CreateDIBSection(hdcScreen, lpbi, DIB_RGB_COLORS, pvBits, 0&, 0)

hdcMonoSection = CreateCompatibleDC(hdcScreen)
hbmMonoSectionSav = SelectObject(hdcMonoSection, hbmMonoSection)

'Bitblt to the Monochrome DIB section
'If a mask color is provided, create a new bitmap and copy the source
'to it transparently. If we don't do this, a dark mask color will be
'turned into the outline part of the monochrome DIB section
'Convert mask color and white before comparing
'because the Mask color might be a system color that would be evaluated
'to white.
OleTranslateColor vbWhite, hPal, lMaskColorCompare
OleTranslateColor clrMask, hPal, lMaskColor
If lMaskColor = lMaskColorCompare Then
BitBlt hdcMonoSection, 0, 0, Width, Height, hdcSrc, XSrc, YSrc, vbSrcCopy
Else
hbmMasked = CreateCompatibleBitmap(hdcScreen, Width, Height)
hdcMaskedSource = CreateCompatibleDC(hdcScreen)
hbmMaskedOld = SelectObject(hdcMaskedSource, hbmMasked)
hpalMaskedOld = SelectPalette(hdcMaskedSource, hPal, True)
RealizePalette hdcMaskedSource
'Fill the bitmap with white
With udtRect
.Left = 0
.Top = 0
.Right = Width
.Bottom = Height
End With
hbrWhite = CreateSolidBrush(vbWhite)
FillRect hdcMaskedSource, udtRect, hbrWhite
DeleteObject hbrWhite
'Do the transparent paint

PaintTransparentDC hdcMaskedSource, 0, 0, Width, Height, hdcSrc, XSrc, YSrc, lMaskColor, hPal

'BitBlt to the Mono DIB section. The mask color has been turned to white.
BitBlt hdcMonoSection, 0, 0, Width, Height, hdcMaskedSource, 0, 0, vbSrcCopy
'Clean up
SelectPalette hdcMaskedSource, hpalMaskedOld, True
RealizePalette hdcMaskedSource
DeleteObject SelectObject(hdcMaskedSource, hbmMaskedOld)
DeleteDC hdcMaskedSource
End If

' Okay, we've got our B&W DIB section.
' Now that we have our monochrome bitmap, the final appearance that we
' want is this: First, think of the black portion of the monochrome
' bitmap as our new version of the original bitmap. We want to have a dark
' gray version of this with a light version underneath it, shifted down and
' to the right. The light acts as a highlight, and it looks like the original
' image is a gray inset.

' First, create a copy of the destination. Draw the light gray transparently,
' and then draw the dark gray transparently

hbmDisabled = CreateCompatibleBitmap(hdcScreen, Width, Height)

hdcDisabled = CreateCompatibleDC(hdcScreen)
hbmDisabledSav = SelectObject(hdcDisabled, hbmDisabled)
hpalDisabledOld = SelectPalette(hdcDisabled, hPal, True)
RealizePalette hdcDisabled
'We used to fill the background with gray, instead copy the
'destination to memory DC. This will allow a disabled image
'to be drawn over a background image.
BitBlt hdcDisabled, 0, 0, Width, Height, hdcDest, XDest, YDest, vbSrcCopy

'When painting the monochrome bitmaps transparently onto the background
'we need a background color that is not the light color of the dark color
'Provide three choices to ensure a unique color is picked.
OleTranslateColor vbBlack, hPal, lMonoBkGrndChoices(0)
OleTranslateColor vbRed, hPal, lMonoBkGrndChoices(1)
OleTranslateColor vbBlue, hPal, lMonoBkGrndChoices(2)

'Pick a background color choice that doesn't match
'the shadow or highlight color
For lIndex = 0 To 2
If lMonoBkGrndChoices(lIndex) <> dwSys3dHighlight And _
lMonoBkGrndChoices(lIndex) <> dwSys3dShadow Then
'This color can be used for a mask
lMonoBkGrnd = lMonoBkGrndChoices(lIndex)
Exit For
End If
Next

' Now paint a the light color shifted and transparent over the background
' It is not necessary to change the DIB section's color table
' to equal the highlight color and mask color. In fact, setting
' the color table to anything besides black and white causes unpredictable
' results (seen in win95 with IE4, using 256 colors).
' Setting the Back and Text colors of the Monochrome bitmap, ensure
' that the desired colors are produced.
With rgbnew(0)
.rgbRed = (vbWhite \ 2 ^ 16) And &HFF
.rgbGreen = (vbWhite \ 2 ^ 8) And &HFF
.rgbBlue = vbWhite And &HFF
End With
With rgbnew(1)
.rgbRed = (vbBlack \ 2 ^ 16) And &HFF
.rgbGreen = (vbBlack \ 2 ^ 8) And &HFF
.rgbBlue = vbBlack And &HFF
End With

SetDIBColorTable hdcMonoSection, 0, 2, rgbnew(0)

'...We can't pass a DIBSection to PaintTransparentDC(), so we need to
' make a copy of our mono DIBSection. Notice that we only need a monochrome
' bitmap, but we must set its back/fore colors to the monochrome colors we
' want (light gray and black), and PaintTransparentDC() will honor them.
hbmMono = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
hdcMono = CreateCompatibleDC(hdcScreen)
hbmMonoSav = SelectObject(hdcMono, hbmMono)
SetMapMode hdcMono, GetMapMode(hdcSrc)
SetBkColor hdcMono, dwSys3dHighlight
SetTextColor hdcMono, lMonoBkGrnd
hpalMonoOld = SelectPalette(hdcMono, hPal, True)
RealizePalette hdcMono
BitBlt hdcMono, 0, 0, Width, Height, hdcMonoSection, 0, 0, vbSrcCopy

'...We can go ahead and call PaintTransparentDC with our monochrome
' copy
' Draw this transparently over the disabled bitmap
'...Don't forget to shift right and left....
PaintTransparentDC hdcDisabled, 1, 1, Width, Height, hdcMono, 0, 0, lMonoBkGrnd, hPal

' Now draw a transparent copy, using dark gray where the monochrome had
' black, and transparent elsewhere. We'll use a transparent color of black.

'...We can't pass a DIBSection to PaintTransparentDC(), so we need to
' make a copy of our mono DIBSection. Notice that we only need a monochrome
' bitmap, but we must set its back/fore colors to the monochrome colors we
' want (dark gray and black), and PaintTransparentDC() will honor them.
' Use hbmMono and hdcMono; already created for first color
SetBkColor hdcMono, dwSys3dShadow
SetTextColor hdcMono, lMonoBkGrnd
BitBlt hdcMono, 0, 0, Width, Height, hdcMonoSection, 0, 0, vbSrcCopy

'...We can go ahead and call PaintTransparentDC with our monochrome
' copy
' Draw this transparently over the disabled bitmap
PaintTransparentDC hdcDisabled, 0, 0, Width, Height, hdcMono, 0, 0, lMonoBkGrnd, hPal
BitBlt hdcDest, XDest, YDest, Width, Height, hdcDisabled, 0, 0, vbSrcCopy
' Okay, we're done!
SelectPalette hdcDisabled, hpalDisabledOld, True
RealizePalette hdcDisabled
DeleteObject SelectObject(hdcMonoSection, hbmMonoSectionSav)
DeleteDC hdcMonoSection
DeleteObject SelectObject(hdcDisabled, hbmDisabledSav)
DeleteDC hdcDisabled
DeleteObject SelectObject(hdcMono, hbmMonoSav)
SelectPalette hdcMono, hpalMonoOld, True
RealizePalette hdcMono
DeleteDC hdcMono
ReleaseDC 0&, hdcScreen
End Sub

'Es utilizado por PaintDisableDC
Public Sub PaintTransparentDC(ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal Width As Long, _
ByVal Height As Long, ByVal hdcSrc As Long, ByVal XSrc As Long, ByVal YSrc As Long, _
ByVal clrMask As OLE_COLOR, Optional ByVal hPal As Long = 0)

Dim hdcMask As Long, hdcColor As Long, hbmMask As Long, hbmColor As Long, hbmColorOld As Long, hbmMaskOld As Long
Dim hPalOld As Long, hdcScreen As Long, hdcScnBuffer As Long, hbmScnBuffer As Long, hbmScnBufferOld As Long
Dim hPalBufferOld As Long, lMaskColor As Long

hdcScreen = GetDC(0&)
'Validate palette
'If hPal = 0 Then
' hPal = m_hpalHalftone
'End If
OleTranslateColor clrMask, hPal, lMaskColor

'Create a color bitmap to server as a copy of the destination
'Do all work on this bitmap and then copy it back over the destination
'when it's done.
hbmScnBuffer = CreateCompatibleBitmap(hdcScreen, Width, Height)
'Create DC for screen buffer
hdcScnBuffer = CreateCompatibleDC(hdcScreen)
hbmScnBufferOld = SelectObject(hdcScnBuffer, hbmScnBuffer)
hPalBufferOld = SelectPalette(hdcScnBuffer, hPal, True)
RealizePalette hdcScnBuffer
'Copy the destination to the screen buffer
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcDest, XDest, YDest, vbSrcCopy

'Create a (color) bitmap for the cover (can't use CompatibleBitmap with
'hdcSrc, because this will create a DIB section if the original bitmap
'is a DIB section)
hbmColor = CreateCompatibleBitmap(hdcScreen, Width, Height)
'Now create a monochrome bitmap for the mask
hbmMask = CreateBitmap(Width, Height, 1, 1, ByVal 0&)
'First, blt the source bitmap onto the cover. We do this first
'and then use it instead of the source bitmap
'because the source bitmap may be
'a DIB section, which behaves differently than a bitmap.
'(Specifically, copying from a DIB section to a monochrome bitmap
'does a nearest-color selection rather than painting based on the
'backcolor and forecolor.
hdcColor = CreateCompatibleDC(hdcScreen)
hbmColorOld = SelectObject(hdcColor, hbmColor)
hPalOld = SelectPalette(hdcColor, hPal, True)
RealizePalette hdcColor
'In case hdcSrc contains a monochrome bitmap, we must set the destination
'foreground/background colors according to those currently set in hdcSrc
'(because Windows will associate these colors with the two monochrome colors)
SetBkColor hdcColor, GetBkColor(hdcSrc)
SetTextColor hdcColor, GetTextColor(hdcSrc)
BitBlt hdcColor, 0, 0, Width, Height, hdcSrc, XSrc, YSrc, vbSrcCopy
'Paint the mask. What we want is white at the transparent color
'from the source, and black everywhere else.
hdcMask = CreateCompatibleDC(hdcScreen)
hbmMaskOld = SelectObject(hdcMask, hbmMask)

'When bitblt'ing from color to monochrome, Windows sets to 1
'all pixels that match the background color of the source DC. All
'other bits are set to 0.
SetBkColor hdcColor, lMaskColor
SetTextColor hdcColor, vbWhite
BitBlt hdcMask, 0, 0, Width, Height, hdcColor, 0, 0, vbSrcCopy
'Paint the rest of the cover bitmap.
'
'What we want here is black at the transparent color, and
'the original colors everywhere else. To do this, we first
'paint the original onto the cover (which we already did), then we
'AND the inverse of the mask onto that using the DSna ternary raster
'operation (0x00220326 - see Win32 SDK reference, Appendix, "Raster
'Operation Codes", "Ternary Raster Operations", or search in MSDN
'for 00220326). DSna [reverse polish] means "(not SRC) and DEST".
'
'When bitblt'ing from monochrome to color, Windows transforms all white
'bits (1) to the background color of the destination hdc. All black (0)
'bits are transformed to the foreground color.
SetTextColor hdcColor, vbBlack
SetBkColor hdcColor, vbWhite
BitBlt hdcColor, 0, 0, Width, Height, hdcMask, 0, 0, DSna
'Paint the Mask to the Screen buffer
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcMask, 0, 0, vbSrcAnd
'Paint the Color to the Screen buffer
BitBlt hdcScnBuffer, 0, 0, Width, Height, hdcColor, 0, 0, vbSrcPaint
'Copy the screen buffer to the screen
BitBlt hdcDest, XDest, YDest, Width, Height, hdcScnBuffer, 0, 0, vbSrcCopy
'All done!
DeleteObject SelectObject(hdcColor, hbmColorOld)
SelectPalette hdcColor, hPalOld, True
RealizePalette hdcColor
DeleteDC hdcColor
DeleteObject SelectObject(hdcScnBuffer, hbmScnBufferOld)
SelectPalette hdcScnBuffer, hPalBufferOld, True
RealizePalette hdcScnBuffer
DeleteDC hdcScnBuffer

DeleteObject SelectObject(hdcMask, hbmMaskOld)
DeleteDC hdcMask
ReleaseDC 0&, hdcScreen
End Sub

'Obtiene información desde un bitmap
Public Sub GetBitmapInfo(ByVal hBmp As Long, ByRef Dx As Long, ByRef Dy As Long, Optional ByRef BitsPixel As Long, Optional ByRef Planes As Long)
Dim bmp As BITMAP
GetBitmap hBmp, Len(bmp), bmp
With bmp
Dx = .bmWidth
Dy = .bmHeight
BitsPixel = .bmBitsPixel
Planes = .bmPlanes
End With
End Sub

'Obtiene el tamaño de un ícono
Public Sub GetIconSize(hIcon As Long, Dx As Long, Dy As Long)
Dim ico As IconInfo, bmp As BITMAP
GetIconInfo hIcon, ico
GetBitmapInfo ico.hbmMask, Dx, Dy
Destroy ico.hbmColor, True
Destroy ico.hbmMask, True
End Sub

'Bitmap con máscara de transparencia
Public Function TransparentBltEX(ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, _
ByVal WidthDest As Long, ByVal HeightDest As Long, ByVal HdcSource As Long, ByVal XSource As Long, ByVal YSource As Long, _
ByVal WidthSource As Long, ByVal HeightSource As Long, ByVal TransColor As Long, ByVal ImitateWinNt4Win95 As Boolean) As Boolean

On Error Resume Next

Dim srcDC, SaveDC, maskDC, invDC, resultDC, bmp As BITMAP, hResultBmp, hSaveBmp, hMaskBmp, hInvBmp, hPrevBmp
Dim hSrcPrevBmp, hSavePrevBmp, hDestPrevBmp, hMaskPrevBmp, hInvPrevBmp, OrigColor, Success
Dim hSrcBmp, lResult As Long
Dim w, H, WD, HD
If ImitateWinNt4Win95 = False Then
SetStretchBltMode hdcDest, STRETCH_DELETESCANS
lResult = (TransparentBlt(hdcDest, XDest, YDest, WidthDest, HeightDest, HdcSource, XSource, YSource, WidthSource, HeightSource, TransColor) <> 0)
If lResult = 0 Then lResult = TransparentBltEX(hdcDest, XDest, YDest, WidthDest, HeightDest, HdcSource, XSource, YSource, WidthSource, HeightSource, TransColor, True)
TransparentBltEX = lResult
Else

'######################################
'Inicio de variables no iniciadas
'######################################
'Obtiene el tamaño del DC Origen
'W = GetDeviceCaps(hdcSource, 40)
'H = GetDeviceCaps(hdcSource, 42)
'Si algún ancho o alto es cero lo lleva a la medida del DC origen
'HeightSource = IIf(HeightSource = 0, H, HeightSource)
'WidthSource = IIf(WidthSource = 0, W, WidthSource)
'HeightDest = IIf(HeightDest = 0, H, HeightDest)
'WidthDest = IIf(WidthDest = 0, W, WidthDest)
WD = WidthDest + XDest
HD = HeightDest + YDest

'######################################
'Creación de Contextos de dispositivos (DCs)
'######################################
'Crea un DC que sirve de origen compatible con el destino
srcDC = CreateCompatibleDC(hdcDest)
'Guarda las características del DC destino y crea un DC compatible (funciona como BackUp)
SaveDC = CreateCompatibleDC(hdcDest)
'Crea un DC compatible para la máscara
maskDC = CreateCompatibleDC(hdcDest)
'Crea un Dc compatible para la imagen invertida
invDC = CreateCompatibleDC(hdcDest)
'Crea un DC compatible para componer la imagen (dispositivo de resultados
resultDC = CreateCompatibleDC(hdcDest)

'######################################
'Crea los mapas de bits necesarios
'######################################
'Crea un Bitmap compatible con el DC origen, del tamaño requerido en el destino
hSrcBmp = CreateCompatibleBitmap(HdcSource, WD, HD)
'Crea un mapa de bits monocromo para el Dc de máscara
hMaskBmp = CreateBitmap(WD, HD, 1, 1, ByVal 0&)
'Crea un mapa de bits monocromo para la imagen invertida
hInvBmp = CreateBitmap(WD, HD, 1, 1, ByVal 0&)
'Crea un mapa de bits color para el Dc donde se compone la imagen
hResultBmp = CreateCompatibleBitmap(hdcDest, WD, HD)
'Crea un mapa de bits color para el Dc de BackUp
hSaveBmp = CreateCompatibleBitmap(hdcDest, WD, HD)

'######################################
'Asigna los mapas de bits
'######################################
'Asigna el mapa de bits en el dispositivo que sirve de origen con la imagen cambiada de tamaño
hSrcPrevBmp = SelectObject(srcDC, hSrcBmp)
'Asigna el mapa de bits origen en la copia del Dc destino
hSavePrevBmp = SelectObject(SaveDC, hSaveBmp)
'Asigna el mapa de bits monocromo al Dc monocromo
hMaskPrevBmp = SelectObject(maskDC, hMaskBmp)
'Asigna el mapa de bits monocromo al Dc inverso
hInvPrevBmp = SelectObject(invDC, hInvBmp)
'Asigna el mapa de bits color al Dc donde se compone la imagen
hDestPrevBmp = SelectObject(resultDC, hResultBmp)
'######################################
'Intercambio de mapas de bits y operaciones Raster
'######################################

SetStretchBltMode hdcDest, STRETCH_DELETESCANS
SetStretchBltMode SaveDC, STRETCH_DELETESCANS
SetStretchBltMode maskDC, STRETCH_DELETESCANS
SetStretchBltMode invDC, STRETCH_DELETESCANS
SetStretchBltMode resultDC, STRETCH_DELETESCANS
SetStretchBltMode srcDC, STRETCH_DELETESCANS
'Cambia el tamaño del mapa de bits origen y lo pasa al DC que sirve de origen para las operaciones
Success = StretchBlt(srcDC, 0, 0, WidthDest, HeightDest, HdcSource, XSource, YSource, WidthSource, HeightSource, vbSrcCopy)
'Copia el mapa de bits origen el el DC de Back Up (Sirve para restaurarla más tarde)
Success = BitBlt(SaveDC, 0, 0, WD, HD, srcDC, 0, 0, vbSrcCopy)
'Establece como color de fondo del Dc Origen el color de transparencia
OrigColor = SetBkColor(srcDC, TransColor)
'Crea el mapa de bits de máscara en el Dc máscara
Success = BitBlt(maskDC, 0, 0, WD, HD, srcDC, 0, 0, vbSrcCopy)
'Reestablece el color de fondo en el Dc origen
TransColor = SetBkColor(srcDC, OrigColor)
'Crea la máscara inversa con AND y la combina con ell color de fondo
Success = BitBlt(invDC, 0, 0, WD, HD, maskDC, 0, 0, vbNotSrcCopy)
'Copia el bitmap de fondo as DC de resultados y crea el bitmap transparente
Success = BitBlt(resultDC, 0, 0, WD, HD, hdcDest, 0, 0, vbSrcCopy)
'Copia el bitmap la máscara con AND pintando la porción del área no transparente del origen
Success = BitBlt(resultDC, 0, 0, WD, HD, maskDC, 0, 0, vbSrcAnd)
'Copia el bitmap de DC inverso el el a´rea transparente de la imagen origen
Success = BitBlt(srcDC, 0, 0, WD, HD, invDC, 0, 0, vbSrcAnd)
'Copia el resultado con XOr para que pueda verse a través de él
'XOR result w/ source bitmap to make background show through.
Success = BitBlt(resultDC, 0, 0, WD, HD, srcDC, 0, 0, vbSrcPaint)

'Muestra el bitmap transparente en el origin
Success = BitBlt(hdcDest, XDest, YDest, WidthDest, HeightDest, resultDC, 0, 0, vbSrcCopy)

'SetStretchBltMode hdcDest, STRETCH_DELETESCANS 'STRETCH_DELETESCANS
'Success = StretchBlt(hdcDest, 0, 0, WidthDest, HeightDest, srcDC, XSource, YSource, WidthDest, HeightDest, vbSrcCopy)
'
'Restaura la imagen origen desde el backup
Success = BitBlt(srcDC, 0, 0, WidthDest, HeightDest, SaveDC, 0, 0, vbSrcCopy)

Salida:
TransparentBltEX = (Success <> 0)
'Libera memoria
'hOrigenPrevBmp = SelectObject(hdcOri, hOrigenPrevBmp)
hPrevBmp = SelectObject(srcDC, hSrcPrevBmp) 'Select orig object
hPrevBmp = SelectObject(SaveDC, hSavePrevBmp) 'Select orig object
hPrevBmp = SelectObject(resultDC, hDestPrevBmp) 'Select orig object
hPrevBmp = SelectObject(maskDC, hMaskPrevBmp) 'Select orig object
hPrevBmp = SelectObject(invDC, hInvPrevBmp) 'Select orig object
'DeleteObject hBmpOrigen
Success = DeleteObject(hSrcBmp)
Success = DeleteObject(hSaveBmp) 'Deallocate system resources.
Success = DeleteObject(hMaskBmp) 'Deallocate system resources.
Success = DeleteObject(hInvBmp) 'Deallocate system resources.
Success = DeleteObject(hResultBmp) 'Deallocate system resources.
Success = DeleteDC(srcDC) 'Deallocate system resources.
Success = DeleteDC(SaveDC) 'Deallocate system resources.
Success = DeleteDC(invDC) 'Deallocate system resources.
Success = DeleteDC(maskDC) 'Deallocate system resources.
Success = DeleteDC(resultDC) 'Deallocate system resources.
End If
End Function

'Pas de Himetrics a Pixels
Public Sub HiMetricToPixels(ByRef xHiMetric As Long, ByRef yHiMetric As Long, iType As PictureTypeConstants, ByVal picHandle As Long)
If iType = vbPicTypeBitmap Or iType = vbPicTypeNone Then
GetBitmapInfo picHandle, xHiMetric, yHiMetric
ElseIf iType = vbPicTypeIcon Then
GetIconSize picHandle, xHiMetric, yHiMetric
ElseIf iType = vbPicTypeEMetafile Or iType = vbPicTypeMetafile Then
xHiMetric = xHiMetric / (rHMPX * Screen.TwipsPerPixelX): yHiMetric = yHiMetric / (rHMPX * Screen.TwipsPerPixelX)
End If
End Sub

'Destruye un ícono o bitmap
Public Sub Destroy(ByVal hdl As Long, Optional ByVal fBitmap As Boolean = True)
If fBitmap = True Then
DestroyBitmap hdl
Else
DestroyIcon hdl
End If
End Sub

'Convierte un ícono en un PICTURE
Public Function IconToPicture(ByVal hIcon As Long, Optional ByVal delBmp As Boolean = True) As StdPicture
If hIcon = vbNull Then Exit Function
Dim pic As Picture, picdes As TPictDesc, iidIDispatch As TGuid
' Fill picture description
With picdes
.cbSizeofStruct = Len(picdes)
.picType = vbPicTypeIcon
.hImage = hIcon
End With
' Fill in magic IID number {00020400-0000-0000-C000-000000046}
With iidIDispatch
.Data1 = &H20400
.Data4(0) = &HC0
.Data4(7) = &H46
End With
' Create picture from icon handle, ignoring error return
Call OleCreatePictureIndirect(picdes, iidIDispatch, delBmp, pic)
' Result will be valid Picture or Nothing--either way set it
Set IconToPicture = pic
End Function

'Convierte un birmap a imagen
Function BitmapToPicture(ByVal hBmp As Long, Optional ByVal hPal As Long = vbNull, Optional ByVal delBmp As Boolean = True) As IPicture
Dim ipic As IPicture, picdes As TPictDesc, iidIPicture As TGuid

With picdes
.cbSizeofStruct = Len(picdes)
.picType = vbPicTypeBitmap
.hImage = hBmp
.yExt = hPal
End With

' Fill in magic IPicture GUID {7BF80980-BF32-101A-8BBB-00AA00300CAB}
With iidIPicture
.Data1 = &H7BF80980
.Data2 = &HBF32
.Data3 = &H101A
.Data4(0) = &H8B
.Data4(1) = &HBB
.Data4(2) = &H0
.Data4(3) = &HAA
.Data4(4) = &H0
.Data4(5) = &H30
.Data4(6) = &HC
.Data4(7) = &HAB
End With
'Create picture from bitmap handle
OleCreatePictureIndirect picdes, iidIPicture, delBmp, ipic
'Result will be valid Picture or Nothing either way set it
Set BitmapToPicture = ipic
End Function

'Bitmap semitransparentes
Public Function AlphaBlendEx(ByVal SourceConstantAlpha As Long, _
ByVal hdcDest As Long, ByVal XDest As Long, ByVal YDest As Long, ByVal WidthDest As Long, ByVal HeightDest As Long, _
ByVal HdcSource As Long, ByVal XSource As Long, ByVal YSource As Long, ByVal WidthSource As Long, ByVal HeightSource As Long, _
Optional ByVal ImitateWinNt4Win95 As Boolean = False) As Boolean

Dim OldStretchMode As Long, f As Boolean
OldStretchMode = GetStretchBltMode(HdcSource)
SetStretchBltMode HdcSource, HALFTONE
If ImitateWinNt4Win95 = False Then
Dim SCAlpha As Byte, lng As Long
'SCAlpha = 255 - SourceConstantAlpha
SCAlpha = SourceConstantAlpha
Dim BF As BLENDFUNCTION, lBF As Long
With BF
.BlendOp = AC_SRC_OVER
.BlendFlags = 0
.SourceConstantAlpha = SCAlpha
.AlphaFormat = 0
End With
CopyMemory lBF, BF, 4
f = (AlphaBlend(hdcDest, XDest, YDest, WidthDest, HeightDest, HdcSource, XSource, YSource, WidthSource, HeightSource, lBF) <> 0)
If f = False Then GoTo Salida2
Else
Dim k As Long, j As Long, xRed As Long, xBlue As Long, xGreen As Long, ConstantAlpha As Single
Dim correc As Long, D As Long, lngColor As Long, xColor As Long
Dim hHdc As Long, hBmp As Long, hOldBmp As Long, oldSbm As Long
correc = -(15 / 128 ^ 2) * SourceConstantAlpha ^ 2 + (30 / 128) * SourceConstantAlpha
lngColor = vbMagenta

On Error Resume Next '255 -
ConstantAlpha = ((SourceConstantAlpha + correc) / 255)
hHdc = CreateCompatibleDC(HdcSource)
hBmp = CreateCompatibleBitmap(HdcSource, WidthDest, HeightDest)
hOldBmp = SelectObject(hHdc, hBmp)
oldSbm = GetStretchBltMode(hHdc)
SetStretchBltMode hHdc, HALFTONE
f = (StretchBlt(hHdc, 0, 0, WidthDest, HeightDest, HdcSource, XSource, YSource, WidthSource, HeightSource, vbSrcCopy) <> 0)
If f = False Then GoTo Salida
Dim dRed As Long, dGreen As Long, dBlue As Long, oRed As Long, oGreen As Long, oBlue As Long
For k = 0 To WidthDest
For j = 0 To HeightDest
xColor = GetPixel(hdcDest, k + XDest, j + YDest)
lngColor = GetPixel(hHdc, k, j)
SetPixel hdcDest, k + XDest, j + YDest, _
RGB(CompensarByte((lngColor And &HFF) * ConstantAlpha + (1 - ConstantAlpha) * (xColor And &HFF)), _
CompensarByte(((lngColor \ &H100) And &HFF) * ConstantAlpha + (1 - ConstantAlpha) * ((xColor \ &H100) And &HFF)), _
CompensarByte(((lngColor \ &H10000) And &HFF) * ConstantAlpha + (1 - ConstantAlpha) * ((xColor \ &H10000) And &HFF)))
Next j
Next k
SetStretchBltMode hHdc, oldSbm
SelectObject hHdc, hOldBmp
DeleteObject hBmp
DeleteDC hHdc
f = True
End If
Salida:
SetStretchBltMode HdcSource, OldStretchMode
AlphaBlendEx = f
Exit Function
Salida2:
SetStretchBltMode HdcSource, OldStretchMode
AlphaBlendEx = AlphaBlendEx(SourceConstantAlpha, HdcSource, XSource, YSource, WidthSource, HeightSource, hdcDest, XDest, YDest, WidthDest, HeightDest, True)
End Function

Private Function CompensarByte(ByVal lByte As Long) As Byte
'lByte = Abs(lByte)
If lByte > 255 Then
lByte = 255
ElseIf lByte < 0 Then
lByte = 0
End If
CompensarByte = lByte
End Function

'Obtiene las componentes de un color RGB
Public Sub GetComponentsColor0(ByVal lngColor As Long, ByRef Red As Byte, ByRef Green As Byte, ByRef Blue As Byte)
On Error Resume Next
Dim B() As Byte
ReDim B(1 To 4) As Byte
GetComponentsColor2 B(1), lngColor, 4 'OJO ES COPYMEMORY CON OTRO NOMBRE
Red = B(1)
Green = B(2)
Blue = B(3)
ReDim B(1) As Byte
Erase B
End Sub

Si me enviás una dirección de correo válida te envío el módulo completo

Saludos Ruri