[Aporte]Transparencia en formularios - Plus Configurable

FrmInvF

Mod_InvF

HScroll1

Private Sub Form_Load()
 
    HScroll1.Max = 255
    HScroll1.Min = 50
 
    HScroll1.Value = 150
 
End Sub
 
Private Sub HScroll1_Change()

    Call Aplicar_Transparencia(Me.hWnd, CByte(HScroll1.Value))
 
End Sub

Option Explicit
Private Declare Function SetLayeredWindowAttributes Lib "user32" _
                (ByVal hWnd As Long, _
                ByVal crKey As Long, _
                ByVal bAlpha As Byte, _
                ByVal dwFlags As Long) As Long
               
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 Const GWL_EXSTYLE = (-20)
Private Const LWA_ALPHA = &H2
Private Const WS_EX_LAYERED = &H80000
 
Public Function Is_Transparent(ByVal hWnd As Long) As Boolean
On Error Resume Next
 
Dim Msg As Long
 
    Msg = GetWindowLong(hWnd, GWL_EXSTYLE)
       
      If (Msg And WS_EX_LAYERED) = WS_EX_LAYERED Then
          Is_Transparent = True
      Else
          Is_Transparent = False
      End If
 
    If Err Then
      Is_Transparent = False
    End If
 
End Function
Public Function Aplicar_Transparencia(ByVal hWnd As Long, _
                                      Valor As Integer) As Long
 
Dim Msg As Long
 
On Error Resume Next
 
If Valor < 0 Or Valor > 255 Then
  Aplicar_Transparencia = 1
Else
  Msg = GetWindowLong(hWnd, GWL_EXSTYLE)
  Msg = Msg Or WS_EX_LAYERED
   
  SetWindowLong hWnd, GWL_EXSTYLE, Msg

  SetLayeredWindowAttributes hWnd, 0, Valor, LWA_ALPHA
 
  Aplicar_Transparencia = 0
 
End If
 
 
If Err Then
  Aplicar_Transparencia = 2
End If
 
End Function