2004-05-26 17:52

'Modificado para RapidQ por Jordi Ramos 26/05/2004

'************************************************************************************
'* DLL d'affichage des ombres de boite de dialogue                                   *
'* Auteur : Patrice Ongla                                                           *
'*                                                                            *
'************************************************************************************
'
'Modifié le 18/05/1999

'Cette DLL permet d'ombrer une fenêtre Windows quelconque.
'Elle projette sur la fenêtre située derrière la boîte (dite "support de l'ombre") une ombre
'floue en semi-transparence, décalée en bas et à droite.
'Elle est accessible par deux fonctions d'interface : la fonction "Ombrer" et la fonction
'"Ombrer_Std". La 1ère offre le parametrage de la profondeur de l'ombre (sa largeur), de son
'intensité et de son flou, la deuxième utilise des valeurs prédéfinies pour ces paramètres.

'Le principe de base est le suivant : on crée en mémoire un bitmap compatible avec l'écran
'et on y copie la portion de l'écran correspondant à l'objet à ombrer (la largeur dépend de la
'taille de la fenêtre à ombrer et de la profondeur de l'ombre demandée). On manipule les pixels
'du bitmap mémoire en les assombrissant plus ou moins selon la distance depuis le bord de
'l'objet à ombrer, l'intensité spécifié pour l'ombre et le flou. Enfin, on recopie le bitmap
'modifié à son emplacement sur l'élément (à priori la form) sur lequel l'ombre est projetée.

'NB : La recopie est effectuée dans le contexte graphique du support de l'ombre (la form située
'derrière) ce qui présente l'avantage de ne pas avoir à gérer de zone de clipping (zone de rafraî-
'chissement) pour éviter les peintures inopportunes sur des fenêtres d'autres programmes. Cependant,
'cela empêche aussi de le faire dans les cas où on le souhaiterait (porter l'ombre sur le bureau
'Windows ou dans une autre application par exemple). Pour pouvoir le faire, il faut recopier le
'bitmap dans le contexte graphique de l'écran lui-même et se débrouiller tout seul comme un grand
'avec la gestion de la zone de clipping (pas très accessible en VB, préférer le C).

'NB : l'image de l'ombre est liée à l'écran physique et pas à la fenêtre. Ainsi, elle n'est
'pas rafraîchie avec l'objet ombré comme un de ses composant normaux. Il appartient donc à
'l'utilisateur de la dll de repeindre l'ombre à chaque rafraîchissement de l'objet ombré.

'************************************************************************************

'Option Explicit
     $TYPECHECK ON

     DECLARE FUNCTIONI AttenueOmbre(...) AS DOUBLE
     DECLARE FUNCTION Correct_RGB(Couleur AS LONG) AS LONG
     DECLARE SUBI Ombrer_Std(...)
     DECLARE SUB Peindre_Ombre(hdc AS LONG, hWinUnder AS LONG, Zone AS Rect, _
      IntOmbre AS INTEGER, BYVAL Flou AS SINGLE, Sens AS INTEGER)
     DECLARE SUB Ombrer(HWinObjetAOmbrer AS LONG, hWinSupportOmbre, IntensiteOmbre AS INTEGER, _
      ProfondeurOmbre AS INTEGER, FlouOmbre AS SINGLE)





'Private Function AttenueOmbre(A As Integer, B As Integer, x As Integer, Optional DeCroissante) As Double
     FUNCTIONI AttenueOmbre(...) AS DOUBLE
'Cette fonction rend le coeff d'attenuation de l'ombre en un point à une
'distance x du début de l'ombre en A pour une ombre allant de A à B.
'Elle varie entre 1 et 0 sur [AB] avec des asymptotes horizontales en A et B
'(c'est un cos(x) avec un changement de repère).
'"DeCroissante" indique que l'ombre s'atténue (DeCroissante = True)
'ou qu'elle s'intensifie qd x grandit .

'-----------------------------------------------------------------------
      DIM a AS INTEGER, b AS INTEGER, x AS INTEGER, DeCroissante AS INTEGER
      a = PARAMVAL(1) : b = PARAMVAL(2): x = PARAMVAL(3)
      IF PARAMVALCOUNT = 4 THEN DeCroissante = PARAMVAL(4)
'-----------------------------------------------------------------------
      DIM y AS DOUBLE
      DIM PI AS DOUBLE

      PI = 4 * ATN(1)
'    If IsMissing(DeCroissante) Then
      IF PARAMVALCOUNT <> 4 THEN
       y = (COS((PI * (x - A) / (B - A))))
       y = (y + 1) / 2
      ELSEIF DeCroissante THEN
       y = (COS((PI * (x - A) / (B - A))))
       y = (y + 1) / 2
      ELSE
       y = (COS((PI * (A - x) / (A - B))))
        'y = (Cos((PI * (x - A) / (B - A)) + PI))
       y = (y + 1) / 2
      END IF
      AttenueOmbre = y
     END FUNCTION


     FUNCTION Correct_RGB(Couleur AS LONG) AS LONG
'Corrige les valeurs négatives de couleur RGB et rend 0 à la place.
      IF Couleur < 0 THEN Correct_RGB = 0 ELSE Correct_RGB = Couleur
     END FUNCTION

'Sub Ombrer_Std(HWinObjetAOmbrer As Long, Optional hWinSupportOmbre As Long)
     SUBI Ombrer_Std(...)
'Ombrage avec paramètres prédéfinis.
'On passe en paramètre le handle de l'objet à ombrer et celui du support de l'ombre
'voir procédure "Ombrer" pour détails.
'Si hWinSupportOmbre n'est pas défini, on ombre sur tout l'arrière plan de la fenêtre
'de handle HWinObjetAOmbrer.

'-----------------------------------------------------------------------
      DIM HWinObjetAOmbrer AS LONG, hWinSupportOmbre AS LONG
      HWinObjetAOmbrer = PARAMVAL(1)
      IF PARAMVALCOUNT = 2 THEN hWinSupportOmbre = PARAMVAL(2)
'-----------------------------------------------------------------------

      IF PARAMVALCOUNT <> 2 THEN
       Ombrer HWinObjetAOmbrer, GetDesktopWindow, STD_INTENSITE, STD_PROFONDEUR, STD_FLOU
      ELSE
       Ombrer HWinObjetAOmbrer, hWinSupportOmbre, STD_INTENSITE, STD_PROFONDEUR, STD_FLOU
      END IF
     END SUB

     SUB Peindre_Ombre(hdc AS LONG, hWinUnder AS LONG, Zone AS Rect, _
       IntOmbre AS INTEGER, BYVAL Flou AS SINGLE, Sens AS INTEGER)

'Cette procédure ombre la zone passée en paramètre en assombrissant chaque pixel.
'"Sens" permet de spécifier s'il s'agit de l'ombre droite ou de l'ombre basse.
'   0 pour droite, 1 pour basse, 2 pour coin bas droit
'"HWinUnder" est le handle de la fenêtre située sous la fenêtre à ombrer.

'L'Peindre_Ombre est régulier sur une distance égale à une proportion de la largeur de l'ombre
'définie par "Flou" puis son intensité diminue jusqu'à 0 au bord de l'ombre. Le coeff
'd'intensité varie donc sur une droite horizontale (constante) puis décroit sur un "S"
'(vérifier qu'on a bien deux asymptotes horizontales aux limites) défini par une équation
'de la forme : C = cos(i) où i est une coordonnée.

      DIM Color_Init AS LONG
      DIM C_Rouge AS LONG
      DIM C_Bleu AS LONG
      DIM C_Vert AS LONG
      DIM CoeffAttenuation AS DOUBLE 'pour gérer le flou de l'ombre (dégradé d'intensité)
      DIM IntOmbreLoc AS INTEGER 'pour gérer le flou de l'ombre (dégradé d'intensité)
    'Dim C_Transp As Long
      DIM X1 AS INTEGER
      DIM Y1 AS INTEGER
      DIM X2 AS INTEGER
      DIM Y2 AS INTEGER
      DIM XLimiteFlou AS INTEGER
      DIM YLimiteFlou AS INTEGER
'nécessaire pour les angles puisqu'il faut faire progresser l'indice
'en fonction de la distance au coin cad le rayon du quart de cercle de
'centre le coin inférieur droit.
      DIM Rayon AS INTEGER

      X1 = Zone.Left
      Y1 = Zone.Top
      X2 = Zone.Right
      Y2 = Zone.Bottom
'On determine un coeef mult. de l'intensité tel que l'intensité est maximale (coeff = 1) pour
'les petites abcisses et ordonnées et minimale pour les grandes (coeff = 0) selon la progression
'définie ci-dessus.

      DIM Temp_Res AS LONG

      Flou = 1 + Flou / 10
    'MsgBox "Flou : " & Flou
      SELECT CASE Sens
      CASE 0 'Ombre verticale
       XLimiteFlou = X1 + (X2 - X1) / Flou
            'MsgBox "Ombre verticale ; Flou = " & Flou & vbCrLf & _
            '        "X1 = " & X1 & ", XLimiteFlou = " & XLimiteFlou & ", X2 = " & X2
      CASE 1 'Ombre horizontale
       YLimiteFlou = Y1 + (Y2 - Y1) / Flou
            'MsgBox "Ombre horizontale ; Flou = " & Flou & vbCrLf & _
            '        "Y1 = " & Y1 & ", YLimiteFlou = " & YLimiteFlou & ", Y2 = " & Y2
      CASE 2 'Ombre coin inférieur droit
       XLimiteFlou = X1 + (X2 - X1) / Flou
       YLimiteFlou = Y1 + (Y2 - Y1) / Flou
      CASE 3 'Ombre coin supérieur droit
       XLimiteFlou = X1 + (X2 - X1) / Flou
       YLimiteFlou = Y2 - (Y2 - Y1) / Flou
      CASE 4 'Ombre coin inférieur gauche
       XLimiteFlou = X2 - (X2 - X1) / Flou
       YLimiteFlou = Y1 + (Y2 - Y1) / Flou
      END SELECT

      DIM i AS INTEGER
      DIM j AS INTEGER
      FOR i = X1 TO X2
       FOR j = Y1 TO Y2
        SELECT CASE Sens
        CASE 0 'Ombre verticale
         IF i < XLimiteFlou OR XLimiteFlou = X2 THEN
          CoeffAttenuation = 1
         ELSE
                        'CoeffAttenuation = ((i * (X2 - i)) / (X1 * (X2 - X1)))
          CoeffAttenuation = AttenueOmbre(XLimiteFlou, X2, i)
                        'Debug.Print CoeffAttenuation
         END IF
        CASE 1 'Ombre horizontale
         IF j < YLimiteFlou OR YLimiteFlou = Y2 THEN
          CoeffAttenuation = 1
         ELSE
          CoeffAttenuation = AttenueOmbre(YLimiteFlou, Y2, j)
         END IF
        CASE 2 'Ombre coin inférieur droit
         IF i < XLimiteFlou OR XLimiteFlou = X2 THEN
          CoeffAttenuation = 1
         ELSE
          CoeffAttenuation = AttenueOmbre(XLimiteFlou, X2, i)
         END IF
         IF j > YLimiteFlou AND NOT YLimiteFlou = Y2 THEN
          CoeffAttenuation = CoeffAttenuation * AttenueOmbre(YLimiteFlou, Y2, j)
         END IF
        CASE 3 'Ombre coin supérieur droit
         IF i < XLimiteFlou OR XLimiteFlou = X2 THEN
          CoeffAttenuation = 1
         ELSE
          CoeffAttenuation = AttenueOmbre(XLimiteFlou, X2, i)
         END IF
         IF j < YLimiteFlou THEN
          CoeffAttenuation = CoeffAttenuation * AttenueOmbre(YLimiteFlou, Y1, j, False)
         END IF
        CASE 4 'Ombre coin inférieur gauche
         IF i > XLimiteFlou OR XLimiteFlou = X1 THEN
          CoeffAttenuation = 1
         ELSE
          CoeffAttenuation = AttenueOmbre(XLimiteFlou, X1, i, False)
         END IF

         IF j > YLimiteFlou THEN
          CoeffAttenuation = CoeffAttenuation * AttenueOmbre(YLimiteFlou, Y2, j)
         END IF
        END SELECT

            'Prise en compte du flou
        IntOmbreLoc = IntOmbre * CoeffAttenuation

            'Assombrissement des pixels
        Color_Init = GetPixel(hdc, i, j)
'            C_Rouge = (Color_Init And vbRed)
        C_Rouge = (Color_Init AND clRed)
        C_Rouge = C_Rouge - (C_Rouge / 255) * IntOmbreLoc
'            C_Vert = (Color_Init And vbGreen) / (vbRed + 1)
        C_Vert = (Color_Init AND clGreen) / (clRed + 1)
        C_Vert = C_Vert - (C_Vert / 255) * IntOmbreLoc
'            C_Bleu = (Color_Init And vbBlue) / (vbGreen + vbRed + 1)
        C_Bleu = (Color_Init AND clBlue) / (clGreen + clRed + 1)
        C_Bleu = C_Bleu - (C_Bleu / 255) * IntOmbreLoc

        Color_Init = RGB(Correct_RGB(C_Rouge), Correct_RGB(C_Vert), Correct_RGB(C_Bleu))
        Temp_Res = SetPixelV(hdc, i, j, Color_Init)
       NEXT j
      NEXT i
     END SUB




     SUB Ombrer(HWinObjetAOmbrer AS LONG, hWinSupportOmbre, IntensiteOmbre AS INTEGER, _
       ProfondeurOmbre AS INTEGER, FlouOmbre AS SINGLE)
'Peind une ombre de la fenêtre de handle "HWinObjetAOmbrer" sur la fenêtre de handle
'"hWinSupportOmbre" via un tampon mémoire.
'Pour accélérer le traitement, on ne copie pas tous l'écran dans le tampon mais seulement
'une zone rectangulaire un peu plus grande que l'objet à ombrer.
'NB : les repère de coordonnées du tampon mémoire est exactement le même que celui de l'écran.
'il n'y aucune manip de changement de repère à faire lors des opérations de copie de l'un
'vers l'autre.

'NB : Cette procédure ne fonctionne que sur des fenêtres au sens système du terme car il faut un
'handle de fenêtre.

'    On Error GoTo Err_Ombrer

'*****************************************************************************************************
'Declarations

      DIM RectOmbre AS Rect
      DIM PosXOmbre AS INTEGER
      DIM PosYOmbre AS INTEGER
      DIM HauteurOmbre AS INTEGER
      DIM LargeurOmbre AS INTEGER
      DIM Rect_Fenetre AS Rect 'rectangle de la fenêtre
      DIM Rect_Cl_Support AS Rect 'rectangle de la zone client de la fenêtre support
      DIM Handle_Screen_DC AS LONG  'handle contexte graphique de l'écran
      DIM hWin_Screen AS LONG 'handle de la fenêtre bureau (le desktop-écran)
      DIM hDCSupportOmbre AS LONG 'DC de la fenêtre où l'ombre est portée (peinte)
      DIM hWinUnder AS LONG 'handle de la fenêtre située sous la fenêtre à ombrer. En prévision d'une
                          'gestion de l'étagement de l'ombre sur les fenêtres situées sous l'objet.
      DIM hObjetDC AS LONG 'DC de l'objet à ombrer

'le buffer graphique
      DIM hMemDC AS LONG
      STATIC hMemBitmap AS LONG
      DIM hPrevBitmap AS LONG 'handle du bitmap précédement selectionné
      DIM BufferRect AS Rect 'rectangle du buffer
      DIM X_Buffer AS INTEGER 'coordonnées du buffer
      DIM Y_Buffer AS INTEGER 'coordonnées du buffer
      DIM H_Buffer AS INTEGER
      DIM L_Buffer AS INTEGER

'*****************************************************************************************************
      hWin_Screen = GetDesktopWindow

      Handle_Screen_DC = GetDC(0) 'récupère le handle du contexte graphique de l'écran

      hDCSupportOmbre = GetWindowDC(hWinSupportOmbre)

      GetWindowRect HWinObjetAOmbrer, Rect_Fenetre
      GetWindowRect hWinSupportOmbre, Rect_Cl_Support

      IF ProfondeurOmbre MOD 2 <> 0 THEN ProfondeurOmbre = ProfondeurOmbre + 1
    'la valeur de ProfondeurOmbre est rendue paire car les valeurs impaires créent un petit
    'décalage disgrââââcieuuhhhx. Et dans la maison, on fait dans l'élégant. Oui môssieur.

'Repèrage de la position et des dimensions de l'objet à ombrer
      X_Buffer = Rect_Fenetre.Left
      Y_Buffer = Rect_Fenetre.Top
      L_Buffer = Rect_Fenetre.Right - Rect_Fenetre.Left + ProfondeurOmbre  'de l'ombre à peindre autour de l'objet.
      H_Buffer = Rect_Fenetre.Bottom - Rect_Fenetre.Top + ProfondeurOmbre  'on ajoute "ProfondeurOmbre" pour tenir compte
    'HWinUnder = WindowFromPoint(Rect_Fenetre.Right + 1, Rect_Fenetre.Bottom + 1) 'récupère le handle de la fenêtre du dessous

'Modification des dimensions du buffer en fonction de la région de clipping
    'création d'une région
      BufferRect.Top = Y_Buffer
      BufferRect.Left = X_Buffer
      BufferRect.Bottom = Y_Buffer + H_Buffer
      BufferRect.Right = X_Buffer + L_Buffer

'On définit le bitmap à stocker dans le contexte mémoire avec des dimensions suffisantes (un rectangle
'de la taille de l'objet ombré + la taille de l'ombre.
      hMemBitmap = CreateCompatibleBitmap(Handle_Screen_DC, X_Buffer + L_Buffer, Y_Buffer + H_Buffer)
      IF hMemBitmap = 0 THEN SHOWMESSAGE "c'est foutu"
      hMemDC = CreateCompatibleDC(Handle_Screen_DC)

'on stocke la zone à redessiner dans le tampon mémoire.
      hPrevBitmap = SelectObject(hMemDC, hMemBitmap)
    'MsgBox "Selected object Id : " & hPrevBitmap & " ; Nouveau : " & hMemBitmap
    'MsgBox "X_Buffer : " & X_Buffer

      BitBlt hMemDC, X_Buffer, Y_Buffer, L_Buffer, H_Buffer, _
       Handle_Screen_DC, X_Buffer, Y_Buffer, SRCCOPY

'Début de la définition des ombres
'Ombre verticale
      PosXOmbre = Rect_Fenetre.Right
      PosYOmbre = Rect_Fenetre.Top + ProfondeurOmbre + ProfondeurOmbre / 2
      HauteurOmbre = (Rect_Fenetre.Bottom - Rect_Fenetre.Top) - 1 - ProfondeurOmbre / 2
      LargeurOmbre = ProfondeurOmbre
      RectOmbre.Left = PosXOmbre
      RectOmbre.Top = PosYOmbre
      RectOmbre.Right = PosXOmbre + LargeurOmbre
      RectOmbre.Bottom = PosYOmbre + HauteurOmbre - ProfondeurOmbre

      Peindre_Ombre hMemDC, hWinUnder, RectOmbre, IntensiteOmbre, FlouOmbre, 0 ', BasFenetre
'Ombre horizontale
      PosXOmbre = Rect_Fenetre.Left + ProfondeurOmbre + ProfondeurOmbre / 2
      PosYOmbre = Rect_Fenetre.Bottom
      HauteurOmbre = ProfondeurOmbre
      LargeurOmbre = (Rect_Fenetre.Right - Rect_Fenetre.Left) - ProfondeurOmbre / 2
      RectOmbre.Left = PosXOmbre
      RectOmbre.Top = PosYOmbre
      RectOmbre.Right = PosXOmbre + LargeurOmbre - ProfondeurOmbre - 1
      RectOmbre.Bottom = PosYOmbre + HauteurOmbre
      Peindre_Ombre hMemDC, hWinUnder, RectOmbre, IntensiteOmbre, FlouOmbre, 1 ', BasFenetre

'Ombre coin inférieur droit
      RectOmbre.Left = RectOmbre.Right + 1
      RectOmbre.Top = RectOmbre.Top '+ 1
      RectOmbre.Right = RectOmbre.Right + ProfondeurOmbre + 1
    'RectOmbre.Bottom = RectOmbre.Bottom 'ça change pas non plus
      Peindre_Ombre hMemDC, hWinUnder, RectOmbre, IntensiteOmbre, FlouOmbre, 2 ', BasFenetre

'Ombre coin supérieur droit
    'RectOmbre.Left = RectOmbre.left 'ça bouge pas
      RectOmbre.Top = RectOmbre.Top - ((Rect_Fenetre.Bottom - Rect_Fenetre.Top) - ProfondeurOmbre / 2) - 1
      RectOmbre.Right = RectOmbre.Right
      RectOmbre.Bottom = RectOmbre.Top + ProfondeurOmbre
      Peindre_Ombre hMemDC, hWinUnder, RectOmbre, IntensiteOmbre, FlouOmbre, 3 ', BasFenetre

'Ombre coin inférieur gauche
      RectOmbre.Top = Rect_Fenetre.Bottom
      RectOmbre.Left = Rect_Fenetre.Left + ProfondeurOmbre / 2 - 1
      RectOmbre.Right = RectOmbre.Left + ProfondeurOmbre
      RectOmbre.Bottom = RectOmbre.Top + ProfondeurOmbre
      Peindre_Ombre hMemDC, hWinUnder, RectOmbre, IntensiteOmbre, FlouOmbre, 4 ', BasFenetre

'Mise à jour de l'écran avec le tampon mémoire
      BitBlt hDCSupportOmbre, (X_Buffer - Rect_Cl_Support.Left), _
       (Y_Buffer - Rect_Cl_Support.Top), _
       L_Buffer, H_Buffer, _
       hMemDC, X_Buffer, Y_Buffer, SRCCOPY

'Libération de la mémoire
      SelectObject hMemDC, hPrevBitmap

    'MsgBox "Suppression du bitmap " & hMemBitmap & " : " & DeleteObject(hMemBitmap) & _
    '        vbCrLf & "Ancien bitmap : " & hPrevBitmap
      IF DeleteObject(hMemBitmap) = 0 THEN SHOWMESSAGE "Problème : bitmap mémoire non supprimé."
      IF DeleteDC(hMemDC) = 0 THEN SHOWMESSAGE "Problème : DC mémoire non supprimé."
      IF ReleaseDC(hWin_Screen, Handle_Screen_DC) = 0 THEN SHOWMESSAGE "Problème : DC mémoire non restitué."
    'MsgBox ReleaseDC(HWin_Screen, Handle_Screen_DC)

Exit_Ombrer:
'    Exit Sub

'Err_Ombrer:
'    Select Case Err
'        Case Else
'            MsgBox "Erreur dans la procédure " & Chr(34) & "Ombrer" & Chr(34) & "."
'            On Error GoTo 0
'            Err.Raise Err 'on propage l'erreur pour gestion par l'application appelante
'    End Select
'    GoTo Exit_Ombrer

     END SUB

2004-05-26 17:52