Título: [DUDA] Transparencia de un color
Publicado por: HJZR4 en 21 Octubre 2007, 17:58 pm
Explico. En un form normal, inserto una imagen de una bola, como puedo indicar que el fondo (morado) sea trasparente?
Título: Re: [DUDA] Transparencia de un color
Publicado por: VirucKingX en 21 Octubre 2007, 18:12 pm
Const LWA_COLORKEY = &H1 Const GWL_EXSTYLE = (-20) Const WS_EX_LAYERED = &H80000
Private Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hWnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hWnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Sub Form_Load()
Dim Ret As Long Dim CLR As Long
CLR = &HFFC0FF ' Aca colocas el color que mas deseas esop. Ret = GetWindowLong(Me.hWnd, GWL_EXSTYLE) Ret = Ret Or WS_EX_LAYERED SetWindowLong Me.hWnd, GWL_EXSTYLE, Ret SetLayeredWindowAttributes Me.hWnd, CLR, 0, LWA_COLORKEY
End Sub Bye
Título: Re: [DUDA] Transparencia de un color
Publicado por: HJZR4 en 21 Octubre 2007, 18:19 pm
Y como se que color es tal? xDD
Título: Re: [DUDA] Transparencia de un color
Publicado por: LeandroA en 21 Octubre 2007, 22:53 pm
abri la imagen con algun editor abanzado y fijate el color o bien cambiaselo a rojo y ponele vbred
Título: Re: [DUDA] Transparencia de un color
Publicado por: HJZR4 en 19 Diciembre 2007, 00:37 am
Pero eso, transparenta el color morado, todo el form... Y si sólo quiero que la imágen se vea transparente y que se vea, lo que hay debajo de la imagen, no lo que hay debajo del form.,...
Título: Re: [DUDA] Transparencia de un color
Publicado por: LeandroA en 19 Diciembre 2007, 11:15 am
hola te paso un modulo para hacerlo con un pictureBox (no con el control image) Option Explicit Private Declare Function CreateRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long Private Declare Function SetWindowRgn Lib "user32" (ByVal hWnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long Private Const RGN_OR As Long = 2&
Private Declare Sub OleTranslateColor Lib "oleaut32.dll" ( _ ByVal clr As Long, _ ByVal hpal As Long, _ ByRef lpcolorref As Long)
Private Type BITMAPINFOHEADER 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
Private Type RGBQUAD rgbBlue As Byte rgbGreen As Byte rgbRed As Byte rgbReserved As Byte End Type
Private Type BITMAPINFO bmiHeader As BITMAPINFOHEADER bmiColors As RGBQUAD End Type
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDC As Long) As Long Private 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 Private Declare Function SelectObject Lib "gdi32" (ByVal hDC As Long, 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 Declare Function GetDIBits Lib "gdi32" (ByVal aHDC 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 Private Declare Function DeleteDC Lib "gdi32" (ByVal hDC As Long) As Long
Private Const BI_RGB As Long = 0& Private Const DIB_RGB_COLORS As Long = 0&
Public Function MakeFormTransparent(Obj As Object, ByVal lngTransColor As Long) Dim hRegion As Long
hRegion = RegionFromBitmap(Obj, lngTransColor) SetWindowRgn Obj.hWnd, hRegion, True DeleteObject hRegion
End Function
Private Function RegionFromBitmap(picSource As Object, ByVal lngTransColor As Long) As Long Dim lngRetr As Long, lngHeight As Long, lngWidth As Long Dim lngRgnFinal As Long, lngRgnTmp As Long Dim lngStart As Long Dim x As Long, y As Long Dim hDC As Long Dim bi24BitInfo As BITMAPINFO Dim iBitmap As Long Dim BWidth As Long Dim BHeight As Long Dim iDC As Long Dim PicBits() As Byte Dim Col As Long Dim OldScaleMode As ScaleModeConstants OldScaleMode = picSource.ScaleMode picSource.ScaleMode = vbPixels hDC = picSource.hDC lngWidth = picSource.ScaleWidth '- 1 lngHeight = picSource.ScaleHeight - 1
BWidth = (picSource.ScaleWidth \ 4) * 4 + 4 BHeight = picSource.ScaleHeight
'Bitmap-Header With bi24BitInfo.bmiHeader .biBitCount = 24 .biCompression = BI_RGB .biPlanes = 1 .biSize = Len(bi24BitInfo.bmiHeader) .biWidth = BWidth .biHeight = BHeight + 1 End With 'ByteArrays in der erforderlichen Größe anlegen ReDim PicBits(0 To bi24BitInfo.bmiHeader.biWidth * 3 - 1, 0 To bi24BitInfo.bmiHeader.biHeight - 1) iDC = CreateCompatibleDC(hDC) 'Gerätekontextunabhängige Bitmap (DIB) erzeugen iBitmap = CreateDIBSection(iDC, bi24BitInfo, DIB_RGB_COLORS, ByVal 0&, ByVal 0&, ByVal 0&) 'iBitmap in den neuen DIB-DC wählen Call SelectObject(iDC, iBitmap) 'hDC des Quell-Fensters in den hDC der DIB kopieren Call BitBlt(iDC, 0, 0, bi24BitInfo.bmiHeader.biWidth, bi24BitInfo.bmiHeader.biHeight, hDC, 0, 0, vbSrcCopy) 'Gerätekontextunabhängige Bitmap in ByteArrays kopieren Call GetDIBits(hDC, iBitmap, 0, bi24BitInfo.bmiHeader.biHeight, PicBits(0, 0), bi24BitInfo, DIB_RGB_COLORS) 'Wir brauchen nur den Array, also können wir die Bitmap direkt wieder löschen. 'DIB-DC Call DeleteDC(iDC) 'Bitmap Call DeleteObject(iBitmap)
lngRgnFinal = CreateRectRgn(0, 0, 0, 0) For y = 0 To lngHeight x = 0 Do While x < lngWidth Do While x < lngWidth And _ RGB(PicBits(x * 3 + 2, lngHeight - y + 1), _ PicBits(x * 3 + 1, lngHeight - y + 1), _ PicBits(x * 3, lngHeight - y + 1) _ ) = lngTransColor x = x + 1 Loop If x <= lngWidth Then lngStart = x Do While x < lngWidth And _ RGB(PicBits(x * 3 + 2, lngHeight - y + 1), _ PicBits(x * 3 + 1, lngHeight - y + 1), _ PicBits(x * 3, lngHeight - y + 1) _ ) <> lngTransColor x = x + 1 Loop If x + 1 > lngWidth Then x = lngWidth lngRgnTmp = CreateRectRgn(lngStart, y, x, y + 1) lngRetr = CombineRgn(lngRgnFinal, lngRgnFinal, lngRgnTmp, RGN_OR) DeleteObject lngRgnTmp End If Loop Next
picSource.ScaleMode = OldScaleMode RegionFromBitmap = lngRgnFinal End Function
y en el formulario agregas un picture1 con esta imagen (http://img394.imageshack.us/img394/4472/back1fd4.gif) Private Sub Form_Load() Picture1.AutoRedraw = True
MakeFormTransparent Picture1, vbMagenta End Sub Saludos
|