Effet de transparence

Télécharger le projet
Commenter

Description

Affichage d'une fenêtre avec un effet de transparence

Source / Exemple : 


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

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

Conclusion :


Tous niveaux

Copier le code source dans une feuille "Form1" comprenant un bouton "Command1".
Télécharger le projet

Codes Sources

A voir également

S'inscrire maintenant

Vous n'êtes pas encore membre ?

inscrivez-vous, c'est gratuit et ça prend moins d'une minute !

Les membres obtiennent plus de réponses que les utilisateurs anonymes.

Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.

Le fait d'être membre vous permet d'avoir des options supplémentaires.

Du même auteur (FENETRES)