[Source] cGlass (Añade efecto AereoGlass a tus aplicaciones)

[skyweb07]

Bueno chic@s aqui les dejo un modulo de clase que se utiliza para aplicarle el efecto aereoglass a nuestras aplicaciones, cabe destacar que dicho efecto solo se encuentra disponible en los sistemas operativos despues de windows XP , es decir Window Vista y Window 7 por lo que no funcionara con versiones anteriores del sistema operativo. Aqui una OCX que hace exactamente lo mismo pero que es de pago : http://www.teebo.com/AeroGlassVB.htm , bueno y aqui una imagen de como queda el efecto :



DESCARGA : http://www.megaupload.com/?d=79ZWGC0X

Saludos y espero que les guste

[isseu]

para q funcione tiene q tener aero o no ?
en vista home basic no funcionaria?

[skyweb07]

Tienes que tener window vista o 7 y tener el aereo por supuesto 

[Karcrack]

No me gusta bajar sources desde MU.

[skyweb07]

No me gusta bajar sources desde MU.

Jaja que pijo con los hostings eh xD .. aqui el de rapid : http://rapidshare.com/files/344068665/cGlass.rar.html

[BlackZeroX]

.
Aquí lo dejo con un efecto de Transición de colores Xao xP

Esta hecho a partir de lq ue puso Skyweb07 solo que corregí algunas cosillas y adiciones el efecto de transicion.

Código (vb) [Seleccionar] Expandir



'
' ////////////////////////////////////////////////////////////////
' //                                                            //
' // Autor: skyweb07.                                           //
' //                                                            //
' // Web: Desconoco la url                                      //
' //                                                            //
' //  Autor de efecto Transicion de Colores, 1 Error coregido   //
' //                    y Simplificacion:                       //
' //                                                            //
' //          BlackZeroX ( Ortega Avila Miguel Angel )          //
' //                                                            //
' // Web: http://InfrAngeluX.Sytes.Net/                         //
' //                                                            //
' // |-> Pueden Distribuir Este Codigo siempre y cuando         //
' // no se eliminen los creditos originales de este codigo      //
' // No importando que sea modificado/editado o engrandesido    //
' // o achicado, si es en base a este codigo es requerido       //
' // el agradacimiento al autor.                                //
' ////////////////////////////////////////////////////////////////
' //               Modulo de Clase "cGlass.cls"                 //
' ////////////////////////////////////////////////////////////////


Option Explicit
Private WithEvents FRM              As Form
Private WithEvents Timer            As Timer
Private Type RECT
   Left                            As Long
   Top                             As Long
   Right                           As Long
   Bottom                          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
End Type

Private Declare Function DwmExtendFrameIntoClientArea Lib "dwmapi.dll" (ByVal hWnd As Long, margin As RECT) As Long
Private Declare Function DwmIsCompositionEnabled Lib "dwmapi.dll" (ByRef pfEnabled As Long) As Long

Private Declare Function OpenThemeData Lib "uxtheme.dll" (ByVal hWnd As Long, ByVal pszClassList As String) As Long
Private Declare Function CloseThemeData Lib "uxtheme.dll" (ByVal hTheme As Long) As Long

Private Declare Function CreateSolidBrush Lib "gdi32.dll" (ByVal crColor As Long) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hDC As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreateCompatibleDC Lib "gdi32.dll" (ByVal hDC As Long) As Long

Private Declare Function GetClientRect Lib "user32.dll" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function FillRect Lib "user32.dll" (ByVal hDC As Long, lpRect As RECT, ByVal hBrush As Long) As Long

Private Declare Function GetVersionEx Lib "kernel32.dll" Alias "GetVersionExA" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private hTheme                      As Long
Private hWnd                        As Long
Private hDC                         As Long
Private BackColor                   As Long
Private TColor                      As Boolean
Private sTrans                      As Long
Private C(2)                        As Integer

Public Function StartGlass(Form As Form, Optional ByVal BackgroundColor As Long = 0, Optional TransColor As Boolean = False, Optional SpeedTrans As Long = 100)
Dim hEnabled                        As Long
Dim OsVersion                       As OSVERSIONINFO
Dim Margenes                        As RECT
   TColor = TransColor
   If sTrans < 1000 Then
       sTrans = SpeedTrans
   Else
       sTrans = 1000
   End If
   If Not BackgroundColor = 0 Then BackColor = (BackgroundColor)
   If Not Form.BorderStyle = 0 Then
       OsVersion.dwOSVersionInfoSize = Len(OsVersion)
       If GetVersionEx(OsVersion) <> 0 Then
           If OsVersion.dwMajorVersion < 6 Then Exit Function
       End If
       Set FRM = Form
       With FRM
           hTheme = OpenThemeData(.hWnd, vbNullString)
           hDC = .hDC
           hWnd = .hWnd
       End With
       Debug.Print hTheme
       With Margenes
           .Left = -1:: .Right = -1: .Top = -1: .Bottom = -1
       End With
       If DwmIsCompositionEnabled(hEnabled) = &H0 Then
           Call DwmExtendFrameIntoClientArea(FRM.hWnd, Margenes)
           Set Timer = FRM.Controls.Add("VB.Timer", "Timer")
           With Timer
               .Interval = sTrans: .Enabled = TColor
           End With
       End If
   End If
End Function

Private Sub Frm_Paint()
   If Not hTheme Then
       Call Paint
   End If
End Sub

Private Sub Paint()
Dim hColor              As Long
Dim hObject             As Long
Dim hRect               As RECT
   hColor = CreateSolidBrush(BackColor)
   hObject = SelectObject(hDC, hColor)
   GetClientRect hWnd, hRect
   FillRect hDC, hRect, hColor
   DeleteObject SelectObject(hDC, hObject)
   DeleteObject hObject
   DeleteObject hColor
End Sub

Private Sub Timer_Timer()
Static nc           As Integer
Static lim          As Byte
Static res          As Boolean
    If lim = 0 Then
        C(0) = ColorCodeToRGB(BackColor)(0) '   //  R
        C(1) = ColorCodeToRGB(BackColor)(1) '   //  G
        C(2) = ColorCodeToRGB(BackColor)(2) '   //  B
    End If
    C(nc) = C(nc) + IIf(res, -1, 1)
    If C(nc) = lim Or lim = 0 Or C(nc) >= 255 Or C(nc) <= 0 Then
        lim = NumeroAleatorio(1, 255)
        nc = NumeroAleatorio(0, 3) - 1
        res = (C(nc) > lim)
    End If
    BackColor = RGB(C(0), C(1), C(2))
    Call Frm_Paint
End Sub

Public Function NumeroAleatorio(MinNum As Long, MaxNum As Long) As Long
Dim Tmp                                 As Long
   If MaxNum < MinNum Then: Tmp = MaxNum: MaxNum = MinNum: MinNum = Tmp
   Randomize: NumeroAleatorio = CLng((MinNum - MaxNum + 1) * Rnd + MaxNum)
End Function

Private Function ColorCodeToRGB(lColorCode As Long) As Integer()
Dim ColorRGB(2)          As Integer
   ColorRGB(2) = (lColorCode And &HFF0000) \ &H10000  '   //  B
   ColorRGB(1) = (lColorCode And &HFF00&) \ &H100     '   //  G
   ColorRGB(0) = (lColorCode And &HFF)                '   //  R
   ColorCodeToRGB = ColorRGB
   Erase ColorRGB
End Function

Public Property Let EnabledTransColor(vData As Boolean)
   TColor = vData
   If Not Timer Is Nothing Then
       Timer.Enabled = TColor
   End If
End Property
Public Property Get EnabledTransColor() As Boolean
   TransColor = TColor
End Property

Public Property Let BackgroundColor(vData As Long)
   BackColor = (vData)
   Call Frm_Paint
End Property
Public Property Get BackgroundColor() As Long
   BackgroundColor = BackColor
End Property

Public Property Let SpeedTrans(vData As Long)
   sTrans = vData
   If Not Timer Is Nothing Then
       Timer.Interval = sTrans
   End If
End Property
Public Property Get SpeedTrans() As Long
   BackgroundColor = sTrans
End Property

Private Sub Class_Terminate()
   If hTheme Then
       Call CloseThemeData(hTheme)
   End If
   Set FRM = Nothing
End Sub



Ejemplo de una llamada Simple:

En un form X pegar

Código (vb) [Seleccionar] Expandir



Option Explicit
Private hGlass              As cGlass
Private Sub Form_Load()
   Set hGlass = New cGlass
   With hGlass
       .StartGlass Me
       .BackgroundColor = vbBlue
       .EnabledTransColor = True
       .SpeedTrans = 10
   End With
End Sub



o

Código (vb) [Seleccionar] Expandir



Option Explicit
Private hGlass              As cGlass
Private Sub Form_Load()
   Set hGlass = New cGlass
   hGlass.StartGlass Me, vbBlue, True, 10
End Sub



se me paso poner esto

Sangrientas Lunas!¡.
.