Aplicar transparencia a formulario de Excel vba

Para este artículo les comparto un tip muy interesante, que seguramente les podrán encontrar un uso útil a sus proyectos y darles un Plus en la presentación.

Pues bien, el tip que les comparto es cómo aplicar transparencia a un formulario desarrollado en vba. Esto mediante la llamada a API’s de Windows.

Lo mejor, y para no hacerles el trabajo complicado, el código es compatible con Windows y Excel de 32 y 64 bits. Para más sobre el tema de compatibilidad visita Hacer macros compatibles con Excel de 32 y 64 bits.

Cómo funciona

El formulario del ejemplo es sencillo y tiene los siguientes controles:

1. 1 CheckBox.
2. 1 control Image.
3. 1 CommandButton.

Al lanzar el formulario usaremos el método vbModeless en valor TRUE para que nos permita seguir utilizando las celdas de Excel sin necesidad de cerrar el formulario.

Figura 1. Formulario sin transparencia.

Mediante llamadas a API’s de Windows lograremos que al elegir el CheckBox con la leyenda “Habilitar transparencia” al formulario se le aplique una transparencia del 50% cuando el CheckBox esté en TRUE.

Figura 2. Formulario con transparencia.

Código vba del formulario

Ubicación: UserForm1

'Declaramos variables compatibles con 32 y 64 bits.
'----------------------------------

#If VBA7 And Win64 Then

    Private Declare PtrSafe Function GetActiveWindow Lib "USER32" () As Long

#Else
    Private Declare Function GetActiveWindow Lib "USER32" () As Long
#End If

'----------------------------------
#If VBA7 And Win64 Then
    #If VBA7 Then
        #If Win64 Then
            Private Declare PtrSafe Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongPtrA" _
                    (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        #Else
            Private Declare Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongA" _
                                                      (ByVal hwnd As LongPtr, ByVal nIndex As Long, ByVal dwNewLong As LongPtr) As LongPtr
        #End If
    #Else
        Private Declare Function SetWindowLongPtr Lib "USER32" Alias "SetWindowLongA" _
                                                  (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
    #End If
#Else
    Private Declare Function SetWindowLong Lib "USER32" Alias "SetWindowLongA" _
                                           (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#End If
'----------------------------------
#If VBA7 And Win64 Then
    #If VBA7 Then
        #If Win64 Then
            Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" _
                    Alias "GetWindowLongPtrA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        #Else
            Private Declare PtrSafe Function GetWindowLongPtr Lib "USER32" _
                    Alias "GetWindowLongA" (ByVal hwnd As LongPtr, ByVal nIndex As Long) As LongPtr
        #End If
    #Else
        Private Declare Function GetWindowLongPtr Lib "USER32" Alias "GetWindowLongA" _
                                                  (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    #End If
#Else
    Private Declare Function GetWindowLong Lib "USER32" Alias "GetWindowLongA" _
                                           (ByVal hwnd As Long, ByVal nIndex As Long) As Long
#End If
'----------------------------------
#If VBA7 And Win64 Then
    Private Declare PtrSafe Function SetLayeredWindowAttributes Lib "USER32" ( _
            ByVal hwnd As LongPtr, ByVal crKey As Integer, _
            ByVal bAlpha As Integer, ByVal dwFlags As Long) As LongPtr
#Else
    Private Declare Function SetLayeredWindowAttributes Lib "USER32" ( _
                                                        ByVal hwnd As Long, ByVal crKey As Integer, _
                                                        ByVal bAlpha As Integer, ByVal dwFlags As Long) As Long
#End If

'----------------------------------
Private Const WS_EX_LAYERED = &H80000
Private Const LWA_COLORKEY = &H1
Private Const LWA_ALPHA = &H2
Private Const GWL_EXSTYLE = &HFFEC
Dim hwnd As Long

Private Sub CheckBox1_Click()
'CheckBox para aplicar transparencia
'
Select Case True
    '
Case CheckBox1.Value
    Call Semitransparent(50)
Case Else
    Call Semitransparent(100)
End Select
'
End Sub
'
Private Sub CommandButton1_Click()
'Cerrar formulario
Unload Me
End Sub

Private Sub Semitransparent(ByVal intLevel As Integer)
'Aplicar transparencia
#If VBA7 And Win64 Then
    Dim lngWinIdx As LongPtr
#Else
    Dim lngWinIdx As Long
#End If
'
#If VBA7 And Win64 Then
    hwnd = GetActiveWindow
    lngWinIdx = GetWindowLongPtr(hwnd, GWL_EXSTYLE)
    SetWindowLongPtr hwnd, GWL_EXSTYLE, lngWinIdx Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd, 0, (255 * intLevel) / 100, LWA_ALPHA
#Else
    hwnd = GetActiveWindow
    lngWinIdx = GetWindowLong(hwnd, GWL_EXSTYLE)
    SetWindowLong hwnd, GWL_EXSTYLE, lngWinIdx Or WS_EX_LAYERED
    SetLayeredWindowAttributes hwnd, 0, (255 * intLevel) / 100, LWA_ALPHA
#End If
'
'Label1.Caption = "Semitransparent level is ..." & (100 - intLevel) & "%"
End Sub

:: Descargar el ejemplo Formulario transparente en Excel vba.rar