EFFET DE TRANSPARENCE

'------------------------- API's -------------------------
Private Declare Function SetLayeredWindowAttributes Lib "user32" _
  (ByVal hwnd As Long, _
  ByVal crKey As Long, _
  ByVal bAlpha As Long, _
  ByVal dwFlags 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 Declare Function GetWindowLong Lib "user32" _
  Alias "GetWindowLongA" _
  (ByVal hwnd As Long, _
  ByVal nIndex As Long) As Long
  
Private Declare Function UpdateWindow Lib "user32" _
(ByVal hwnd As Long) As Long

Private Const GWL_EXSTYLE As Long = (-20)
Private Const WS_EX_LAYERED As Long = &H80000
Private Const LWA_ALPHA As Long = &H2

Private OpApplied As Byte     'Opacité appliquée

'------------------------- Events ------------------------

Private Sub Form_Load()

  'Opacité initiale de 0 (100% de transparence)
  'pour éviter un artefact visuel.
  Call SetTransparency(Me.hwnd, 0)
  'Largeur minimum (commande "Print on click")
   If Me.Width < 5160 Then Me.Width = 5160
   
End Sub

Private Sub Form_Activate()

  'Affichage de la feuille avec effet de transparence
  'et une raison de progression (Offset) de 1.
  Call setFadeIn(Me.hwnd, 1)
  
End Sub

Private Sub Command1_Click()

  'Crée un effet de transparence
  Call SetTransparency(Me.hwnd, 127)
  'Affiche le pourcentage de transparence
  Print vbCr & Space(6) & "Pourcentage de transparence : 100 - ((127/255)*100) = 50,2%"
  Command1.Enabled = False
  
End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)

  'Effacement de la feuille avec effet de transparence
  'et une raison de progression (Offset) de 3.
  Call setFadeOut(Me.hwnd, 3)
  
End Sub

'---------------------- Procedures -----------------------

Sub setFadeIn(lngHWnd As Long, Offset As Byte)

  Dim Attrib As Long
  Dim Opacity As Byte
  
  If 255 Mod Offset = 0 Then
    Attrib = GetWindowLong(lngHWnd, GWL_EXSTYLE)
    Call SetWindowLong(lngHWnd, GWL_EXSTYLE, Attrib Or WS_EX_LAYERED)
    Do
      Call SetLayeredWindowAttributes(lngHWnd, RGB(0, 0, 0), Opacity, LWA_ALPHA)
      Call UpdateWindow(lngHWnd)
      Opacity = Opacity + Offset
    Loop While Opacity <= 255 - Offset
  Else
    Call MsgBox(vbCr & "Valeur incorrecte !" & vbCr & vbCr & _
                       "Veuillez choisir un diviseur de 255 (1, 3, 5, 15, 17 etc.)" & Space(12) & vbCr & _
                       "comme raison de la progression arithmétique.", vbExclamation, " Affichage progressif (alpha blending)")
    Call SetLayeredWindowAttributes(lngHWnd, RGB(0, 0, 0), 255, LWA_ALPHA)
  End If
  
End Sub

Sub SetTransparency(lngHWnd As Long, Opacity As Byte)

  Dim Attrib As Long
  Dim RetVal As Boolean

  Attrib = GetWindowLong(lngHWnd, GWL_EXSTYLE)
  Call SetWindowLong(lngHWnd, GWL_EXSTYLE, Attrib Or WS_EX_LAYERED)
  RetVal = SetLayeredWindowAttributes(lngHWnd, RGB(0, 0, 0), Opacity, LWA_ALPHA)
  OpApplied = Opacity
  If Not RetVal Then
    Call MsgBox(vbCr & "Echec fonctionnel !" & vbCr & vbCr & _
                       "Pour information, l'API ""SetLayeredWindowAttributes"" est implémenté" & Space(12) & vbCr & _
                       "depuis la version 2000 de Windows et n'est pas supporté par Win9x/ME.", vbCritical, " Effet de transparence (alpha blending)")
    End
  End If
   
End Sub

Sub setFadeOut(lngHWnd As Long, Offset As Byte)

  Dim Attrib As Long
  Dim Opacity As Byte
  
  If 255 Mod Offset = 0 Then
    Attrib = GetWindowLong(lngHWnd, GWL_EXSTYLE)
    
    Call SetWindowLong(lngHWnd, GWL_EXSTYLE, Attrib Or WS_EX_LAYERED)
    'A cause du bouton "Command1"
    Opacity = IIf(OpApplied > 0, OpApplied - (OpApplied Mod Offset), 255)
    Do
      Call SetLayeredWindowAttributes(lngHWnd, RGB(0, 0, 0), Opacity, LWA_ALPHA)
      Call UpdateWindow(lngHWnd)
      Opacity = Opacity - Offset
    Loop While Opacity > 0
  Else
    Call MsgBox(vbCr & "Valeur incorrecte !" & vbCr & vbCr & _
                       "Veuillez choisir un diviseur de 255 (1, 3, 5, 15, 17 etc.)" & Space(12) & vbCr & _
                       "comme raison de la progression arithmétique.", vbExclamation, " Effacement progressif (alpha blending)")
  End If
  
End Sub

'---------------------------------------------------------