Fondo de formulario transparente

Fecha: 05/06/2003 (publicado 29/Jun/03)
Autor: Luis Cabrerizo Gómez (Feagurth@gmx.net)


El algoritmo nos permite fijar el fondo de un formulario como transparente, dejando los controles del mismo visibles al usuario y sin transparencias.

A continuación sigue código del modulo en Visual Basic:


'----------------------------------------------------------------------------------------------------
Attribute VB_Name = "Transparent"
Option Explicit 'Declaraciones de los diferentes tipos de regiones a crear 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 CreateEllipticRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long) As Long Private Declare Function CreateRoundRectRgn Lib "gdi32" (ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long, ByVal X3 As Long, ByVal Y3 As Long) As Long Private Declare Function CreatePolygonRgn Lib "gdi32" (lpPoint As POINTAPI, ByVal nCount As Long, ByVal nPolyFillMode As Long) As Long 'POINTAPI tipo requerido para CreatePolygonRgn Private Type POINTAPI X As Long Y As Long End Type 'Fija la region Private Declare Function SetWindowRgn Lib "user32" (ByVal hwnd As Long, ByVal hRgn As Long, ByVal bRedraw As Boolean) As Long 'Combina la region Private Declare Function CombineRgn Lib "gdi32" (ByVal hDestRgn As Long, ByVal hSrcRgn1 As Long, ByVal hSrcRgn2 As Long, ByVal nCombineMode As Long) As Long 'Tipo de combinacion Const RGN_XOR = 3
'----------------------------------------------------------------------------------------------------
Public
Sub MakeTransparent(TransForm As Form) Dim ErrorTest As Double 'en caso de que haya un error, se ignora On Error Resume Next Dim Regn As Long Dim TmpRegn As Long Dim TmpControl As Control Dim LinePoints(4) As POINTAPI 'Puesto que las API trabajan en pixels, cambiamos el modo de escala a pixels TransForm.ScaleMode = 3 'Debe ejecutarse sobre un formulario son bordes. If TransForm.BorderStyle <> 0 Then MsgBox "Cambia el borderstyle a 0!", vbCritical, "ACK!": End 'Hace todo invisible Regn = CreateRectRgn(0, 0, 0, 0) 'Un bucle para controlar cada control en el formulario For Each TmpControl In TransForm 'Si el control es una linea... If TypeOf TmpControl Is Line Then 'Comprueba la inclinacion If Abs((TmpControl.Y1 - TmpControl.Y2) / (TmpControl.X1 - TmpControl.X2)) > 1 Then 'Si es mas vertical que horizontal entonces.. 'Fija los puntos LinePoints(0).X = TmpControl.X1 - 1 LinePoints(0).Y = TmpControl.Y1 LinePoints(1).X = TmpControl.X2 - 1 LinePoints(1).Y = TmpControl.Y2 LinePoints(2).X = TmpControl.X2 + 1 LinePoints(2).Y = TmpControl.Y2 LinePoints(3).X = TmpControl.X1 + 1 LinePoints(3).Y = TmpControl.Y1 Else 'Si es mas horizontal que vertical, entonces... 'Fija los puntos LinePoints(0).X = TmpControl.X1 LinePoints(0).Y = TmpControl.Y1 - 1 LinePoints(1).X = TmpControl.X2 LinePoints(1).Y = TmpControl.Y2 - 1 LinePoints(2).X = TmpControl.X2 LinePoints(2).Y = TmpControl.Y2 + 1 LinePoints(3).X = TmpControl.X1 LinePoints(3).Y = TmpControl.Y1 + 1 End If 'Crea el nuevo poligono con los puntos TmpRegn = CreatePolygonRgn(LinePoints(0), 4, 1) 'Si el control es una figura... ElseIf TypeOf TmpControl Is Shape Then 'si es asi, comprobamos el tipo If TmpControl.Shape = 0 Then 'Es un rectangulo TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height) ElseIf TmpControl.Shape = 1 Then 'Es un cuadrado If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width) Else TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height) End If ElseIf TmpControl.Shape = 2 Then 'Es un ovalo TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + TmpControl.Height + 0.5) ElseIf TmpControl.Shape = 3 Then 'Es un circulo If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateEllipticRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 0.5) Else TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 0.5, TmpControl.Top + TmpControl.Height + 0.5) End If ElseIf TmpControl.Shape = 4 Then 'Es un rectangulo redondeado If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Width / 4, TmpControl.Width / 4) End If ElseIf TmpControl.Shape = 5 Then 'Es un cuadrado redondeado If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2, TmpControl.Top, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height + 1, TmpControl.Top + TmpControl.Height + 1, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2, TmpControl.Left + TmpControl.Width + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width + 1, TmpControl.Width / 4, TmpControl.Width / 4) End If End If 'Si el control es una figura con fondo transparente If TmpControl.BackStyle = 0 Then 'Combinamos la region en memoria y creamos una nueva CombineRgn Regn, Regn, TmpRegn, RGN_XOR If TmpControl.Shape = 0 Then 'Rectangulo TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + TmpControl.Height - 1) ElseIf TmpControl.Shape = 1 Then 'Cuadrado If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 1) Else TmpRegn = CreateRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 1, TmpControl.Top + TmpControl.Height - 1) End If ElseIf TmpControl.Shape = 2 Then 'Ovalo TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + TmpControl.Height - 0.5) ElseIf TmpControl.Shape = 3 Then 'Circulo If TmpControl.Width < TmpControl.Height Then TmpRegn = CreateEllipticRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width - 0.5, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width - 0.5) Else TmpRegn = CreateEllipticRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height - 0.5, TmpControl.Top + TmpControl.Height - 0.5) End If ElseIf TmpControl.Shape = 4 Then 'Rectangulo redondeado If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height, TmpControl.Width / 4, TmpControl.Width / 4) End If ElseIf TmpControl.Shape = 5 Then 'Cuadrado redondeado If TmpControl.Width > TmpControl.Height Then TmpRegn = CreateRoundRectRgn(TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + 1, TmpControl.Top + 1, TmpControl.Left + (TmpControl.Width - TmpControl.Height) / 2 + TmpControl.Height, TmpControl.Top + TmpControl.Height, TmpControl.Height / 4, TmpControl.Height / 4) Else TmpRegn = CreateRoundRectRgn(TmpControl.Left + 1, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + 1, TmpControl.Left + TmpControl.Width, TmpControl.Top + (TmpControl.Height - TmpControl.Width) / 2 + TmpControl.Width, TmpControl.Width / 4, TmpControl.Width / 4) End If End If End If Else 'Crea una region rectangular con estos parametros TmpRegn = CreateRectRgn(TmpControl.Left, TmpControl.Top, TmpControl.Left + TmpControl.Width, TmpControl.Top + TmpControl.Height) End If 'Comprueba que el control tiene ancho o conseguiremos extraños resultados ErrorTest = 0 ErrorTest = TmpControl.Width If ErrorTest <> 0 Or TypeOf TmpControl Is Line Then 'Combina las regiones CombineRgn Regn, Regn, TmpRegn, RGN_XOR End If Next TmpControl 'Crea las regiones SetWindowRgn TransForm.hwnd, Regn, True End Sub '----------------------------------------------------------------------------------------------------

ir al índice