'
' ////////////////////////////////////////////////////////////////
' //                                                            //
' // 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
 
 

 
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
 
 

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