Une boite de message (msgbox) qui se prend pour un popup

Soyez le premier à donner votre avis sur cette source.

Vue 7 709 fois - Téléchargée 801 fois

Description

Une petite source qui montre comment manipuler une bête MsgBox pour en faire un popup.

Cette Source n'utilise que les API Windows et est donc complètement exportable vers VB6. J'ai d'ailleurs mis dans le zip le .bas qui contient tout le code.

Dans cette source vous trouverez:
-une méthode pour récupérer des information sur la barre des taches windows
-une méthode pour modifier une boite de message avant qu'elle ne soit afficher.
-une méthode pour faire défiler du texte dans une boite de message.
-détecter un clic sur la boite et la fermer.

et d'autre petit truc sans prétention.

Source / Exemple :


Option Explicit

Public Type RECT
    Left As Long
    Top As Long
    Right As Long
    Bottom As Long
End Type

Private Type APPBARDATA
    cbSize As Long
    hwnd As Long
    uCallbackMessage As Long
    uEdge As Long
    rc As RECT
    lParam As Long
End Type

Private Type CWPSTRUCT
    lParam As Long
    wParam As Long
    Message As Long
    hwnd As Long
End Type

Type POINTAPI
    x As Long
    y As Long
End Type

' type perso lier à la fonction "WinTaskBarSize"
Private Type ABDSIZE
    ABDWidth As Long  'largeur de la barre (si barre verticale)
    ABDHeight As Long 'hauteur de la barre (si barre horizontale)
End Type

Private Declare Function SetTimer Lib "User32" (ByVal hwnd As Long, ByVal nIDEvent As Long, ByVal uElapse As Long, ByVal lpTimerFunc As Long) As Long
Private Declare Function KillTimer Lib "User32" (ByVal hwnd As Long, ByVal nIDEvent As Long) As Long
Private Declare Function SetWindowText Lib "User32" Alias "SetWindowTextA" (ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function FindWindow Lib "User32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "User32" Alias "FindWindowExA" (ByVal ParenthWnd As Long, ByVal ChildhWnd As Long, ByVal ClassName As String, ByVal Caption As String) As Long
Private Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long

Private Declare Function SetWindowsHookEx Lib "User32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Private Declare Function UnhookWindowsHookEx Lib "User32" (ByVal hHook As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32" () As Long
Private Declare Function SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function SendMessage Lib "user32.dll" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByRef lParam As Any) As Long
Private Declare Function WindowFromPoint Lib "user32" (ByVal xPoint As Long, ByVal yPoint 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 DrawMenuBar Lib "User32" (ByVal hwnd As Long) As Long

'permet de récupérer l'atat des touches clavier et souris
Private Declare Function GetAsyncKeyState Lib "User32" (ByVal uAction As Long) As Long

'permet de récupérer la position en x,y du pointeur de souris
Declare Function GetCursorPos Lib "User32" (lpPoint As POINTAPI) As Long

'permet de recuperer les infos concernant la barre des taches windows
Private Declare Function SHAppBarMessage Lib "shell32" (ByVal dwMessage As Long, ByRef pData As APPBARDATA) As Long
Private Const ABM_GETTASKBARPOS As Long = &H5

' pour travailler avec une message box non modal
Public Declare Function MessageBox Lib "User32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long

' Gestion de la transparence
Private Declare Function SetLayeredWindowAttributes Lib "user32.dll" (ByVal hwnd As Long, ByVal crKey As Long, ByVal bAlpha As Byte, ByVal dwFlags As Long) As Long
Private Declare Function SetWindowLong Lib "user32.dll" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long

'Taille de l'ecran en pixels
Private Declare Function GetSystemMetrics Lib "user32.dll" (ByVal nIndex As Long) As Long
Const SM_CXSCREEN = 0
Const SM_CYSCREEN = 1

'permet de récupérer les positions de la fenetre
Public Declare Function GetWindowRect Lib "User32" (ByVal hwnd As Long, lpRect As RECT) As Long

Public Const MB_SETFOREGROUND As Long = &H10000
Const GWL_STYLE As Long = -16
Const SWP_NOSIZE = &H1
Const SWP_NOZORDER = &H4
Const WS_EX_LAYERED As Long = &H80000
Const LWA_ALPHA As Long = &H2
Const GWL_EXSTYLE As Long = -20
' --------- Contantes de configuration: --------------
Const IntervalTemps As Long = 50 'intervale de temps de l'opacification de la boite de message
Const TransparenceDeFin As Long = 220 '255 -> boite de message completement opaque
Const Titre As String = "Am I a popup ?" 'titre de la boite de message !n'est pas utilisé pour le handle!
Const TheMessage As String = "Boite de Message ou Popup ??? "
' ----------------------------------------------------

Private xPositionMgBox As Long, yPositionMgBox As Long, msgHook As Long, Transparence As Long, wbkHook As Long
Private TransparenceStep As Long, TimerId As Long, nb_3ddI7IHd As Long, NewMessage As String, MgBxWidth As Long, MgBxHeight As Long

Private hwndLabel As Long  'handle du label de la boite de message
Private hwndButton As Long 'handle du bouton de la boite de message
Public hWndMsgBox As Long 'handle de la boite de message
Sub MsgBox_Transparente()
    'C'est ici que tout commence
    'et tout fini !
    
    Const WH_CALLWNDPROC& = 4
    
    Dim x As Long, y  As Long
    Dim ABD As APPBARDATA

    TransparenceStep = -1
    
    'on donne comme position le coin en bas à droite de l'écran avec prise en compte
    'de la hauteur ou de la largeur de la barre des taches en fonction de sa position
    SHAppBarMessage ABM_GETTASKBARPOS, ABD
    'taille de l’écran en X + prise en compte de la largeur de la barre des taches
    xPositionMgBox = GetSystemMetrics(SM_CXSCREEN) - WinTaskBarSize(ABD.uEdge).ABDWidth
    'taille de l'écran en Y + prise en compte de la hauteur de la barre des taches
    yPositionMgBox = GetSystemMetrics(SM_CYSCREEN) - WinTaskBarSize(ABD.uEdge).ABDHeight
    
    Transparence = 0 ' de 0 a 100, 100 = Opaque
    msgHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookMsgbox, 0, GetCurrentThreadId)
    StartTimer
    MessageBox 0&, TheMessage, Titre, vbOKOnly '+ vbInformation
    ArretTimer
    hWndMsgBox = 0
    On Error Resume Next
    If Not Application.WindowState = xlMaximized Then Application.WindowState = xlMaximized
End Sub
Function CloseMsgBox()
    'ici on ferme la boite de message
    'la fermeture est equivalente à un clique sur la croix
    Const WM_CLOSE = &H10
    Call SendMessage(hWndMsgBox, WM_CLOSE, 0, ByVal 0&)
End Function
Private Function ArretTimer() As Boolean
    'ici on arrete le timer
    If Not TimerId = 0 Then
        TimerId = KillTimer(0&, TimerId)
        TimerId = 0
    End If
End Function
Sub StartTimer()
    'ici on lance le timer
    If Not TimerId = 0 Then ArretTimer
    TimerId = SetTimer(0&, 0&, ByVal IntervalTemps, AddressOf upDateMsgBox)
End Sub

Private Sub upDateMsgBox(ByVal lHwnd&, ByVal lMsg&, ByVal lIDEvent&, ByVal lTime&)
    'cette sub modifie une boite de message à partir de sont handle.
    'Elle permet de:
    '-cacher le bouton
    '-ramène la transparence au niveau souhaité
    '-faire défiler le texte
    '-detecter le clic sur la boite
    Const SW_SHOW As Long = 5
    Const SW_HIDE As Long = 0
    Const SM_CYCAPTION = 4
    Const SM_CYEDGE = 46
    Const VK_LBUTTON As Long = &H1

    Dim PositionCursor As POINTAPI
    'Dim stButtonRect As RECT, x As Long, y As Long, wr As RECT
    
    On Error Resume Next
    
    ' si clic il y a:
    If GetAsyncKeyState(VK_LBUTTON) And &H8000 Then
        'permet de recuperer la position du pointeur
        GetCursorPos PositionCursor
        'est t'il sur la boite ?

        '--------Nouvelle methode------
        'on recupere le handle de la fenetre sous le pointeur
        HwndFromPoint = WindowFromPoint(PositionCursor.x, PositionCursor.y)
        'puis on compare avec le handle de la boite de message
        If hWndMsgBox = HwndFromPoint Then Call CloseMsgBox
        '------------------------------
        
        '******ancienne methode******
        'If PositionCursor.x >= xPositionMgBox And PositionCursor.x <= xPositionMgBox + MgBxWidth Then
            'If PositionCursor.y >= yPositionMgBox And PositionCursor.y <= yPositionMgBox + MgBxHeight Then Call CloseMsgBox
        'End If
        '****************************
    End If
    
    If TransparenceStep = -1 And Not hWndMsgBox = 0 Then
        ' recherche du bouton ("Button" est le "ClassName")
        hwndButton = FindWindowEx(hWndMsgBox, ByVal 0&, "Button", vbNullString)
        'on cache le boutton
        ShowWindow hwndButton, SW_HIDE
        'recherche du label("Static" est le "ClassName")
        hwndLabel = FindWindowEx(hWndMsgBox, ByVal 0&, "Static", vbNullString)
        DoEvents
        TransparenceStep = 0
        NewMessage = ""
        nb_3ddI7IHd = 0
    End If
    
    TransparenceStep = TransparenceStep + 5
    If TransparenceStep <= TransparenceDeFin Then '255 -> boite de message completement opaque
        'opacification de la boite de message
        SetWindowLong hWndMsgBox, GWL_EXSTYLE, WS_EX_LAYERED
        SetLayeredWindowAttributes hWndMsgBox, 0&, TransparenceStep, LWA_ALPHA
        TransparenceStep = TransparenceStep + 5
        DoEvents
    End If
    ' deffilement du text dans la boite (gadget mal construit... juste pour essayer ^^)
    If TransparenceStep > 50 Then 'pour que le commencement soit visible on attend un peu
        Select Case nb_3ddI7IHd
            Case 0 'on commence
                nb_3ddI7IHd = 1
                NewMessage = Space$(Len(TheMessage) - 1) & Left$(TheMessage, nb_3ddI7IHd)
            Case 1 To Len(TheMessage) - 1 'du 2ieme caractere au dernier de la variable TheMessage
                nb_3ddI7IHd = nb_3ddI7IHd + 1
                NewMessage = Right$(NewMessage, Len(NewMessage) - 1)
                NewMessage = NewMessage & Mid(TheMessage, nb_3ddI7IHd, 1)
            Case Is >= Len(TheMessage) 'apres le dernier caractere de la variable TheMessage
                                       'jusqu'a la disparition total du message
                nb_3ddI7IHd = nb_3ddI7IHd + 1
                NewMessage = Right$(NewMessage, Len(NewMessage) - 1)
                NewMessage = NewMessage & " "
                If nb_3ddI7IHd = 2 * Len(TheMessage) Then 'le message à terminé sont deffilement donc on recommence
                    nb_3ddI7IHd = 0
                    NewMessage = ""
                End If
        End Select
    End If
    
    ' mise à jour du label
    SetWindowText hwndLabel, NewMessage
    DoEvents
    ' si erreur on ferme la boite de message ce qui aura aussi pour effet d'arreter le timer
    If Not Err = 0 Then Call CloseMsgBox
End Sub
Function HookMsgbox(ByVal ncode As Long, ByVal wParam As Long, msgStruct As CWPSTRUCT) As Long
    'cette fonction permet le renvois d'une boite de message :
    ' - en bas a droite de l'ecran
    ' - sans sa barre de titre
    ' - !!! completement transparente !!! (en fonction de la variable "Transparence" biensure)
    ' - redimensionnee
    '
    Const SM_CYCAPTION = 4
    Const SM_CYEDGE = 46
    Const WM_CREATE& = &H1
    Dim PosFlag&, wr As RECT, Style_3ddI7IHd As Long
    
    With msgStruct
        If .Message = WM_CREATE Then
            Dim S As String, i As Integer
            S = String(255, 0)
            i = InStr(S, vbNullChar)
            If i Then S = Left(S, i - 1)
            UnhookWindowsHookEx msgHook
            hWndMsgBox = .hwnd
            
            'on recupere les positions de la boite de message pour en deduire sa taille
            GetWindowRect .hwnd, wr
            'calcul des dimensions x,y
            MgBxWidth = (wr.Right - wr.Left)
            MgBxHeight = (wr.Bottom - wr.Top)
            'on ajuste la hauteur pour tenir compte du fait que l'on lui enleve la barre de titre
            MgBxHeight = MgBxHeight - (GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYEDGE))
            'on redefinit les valeurs de position
            xPositionMgBox = xPositionMgBox - MgBxWidth
            yPositionMgBox = yPositionMgBox - MgBxHeight
            
            'on enleve la barre de titre
            Style_3ddI7IHd = GetWindowLong(.hwnd, GWL_STYLE) And Not &HC00000
            SetWindowLong .hwnd, GWL_STYLE, Style_3ddI7IHd
            DrawMenuBar .hwnd
            
            'on applique la transparence de depart qui pour la demo est totale
            SetWindowLong .hwnd, GWL_EXSTYLE, WS_EX_LAYERED
            SetLayeredWindowAttributes .hwnd, 0&, 255 * (Transparence / 100), LWA_ALPHA
            
            'on positionne la boite de message
            PosFlag = SWP_NOZORDER 'Or SWP_NOSIZE
            SetWindowPos .hwnd, 0&, xPositionMgBox, yPositionMgBox, MgBxWidth, MgBxHeight, PosFlag
        End If
    End With
End Function
Function WinTaskBarSize(ByVal TaskBarPos As Long) As ABDSIZE
    'Cette fonction renvoie la hauteur de la barre de tache windows si celle-ci est en bas de l'ecran
    'ou sa largeur si celle-ci est à droite de l'ecran
    Dim hWndToolBar As Long
    Dim Wr_3ddI7IHd As RECT
    'valeur renvoyées par defaut
    WinTaskBarSize.ABDHeight = 0
    WinTaskBarSize.ABDWidth = 0
    'on recupere le handle de la barre des taches
    hWndToolBar = FindWindow("Shell_TrayWnd", vbNullString)
    If Not hWndToolBar = 0 Then 'si la barre a été trouvée
        'on recupere les infos de position
        GetWindowRect hWndToolBar, Wr_3ddI7IHd
        'on les utilise pour en determiner la hauteur
        If TaskBarPos = 3 Then WinTaskBarSize.ABDHeight = (Wr_3ddI7IHd.Bottom - Wr_3ddI7IHd.Top) 'si en bas de l'ecran
        If TaskBarPos = 2 Then WinTaskBarSize.ABDWidth = (Wr_3ddI7IHd.Right - Wr_3ddI7IHd.Left) ' si à droite de l'ecran
    End If
End Function

Conclusion :


Cette source a été pour moi un exercice pour essayer de comprendre l'intérêt du "hooking" ainsi que la manipulation d'une fenêtre et des objets quelle contient.

Même si je crois avoir en parti compris l'intérêt du hook il me reste beaucoup à apprendre sur le sujet.

Bonne prog.

A+

Codes Sources

A voir également

Ajouter un commentaire

Commentaire

cs_marco62118
Messages postés
176
Date d'inscription
mercredi 7 avril 2004
Statut
Membre
Dernière intervention
1 avril 2013
1 -
bonjour
je ne suis pas un champion de la programmation!
je voulais simplement modifier la taille d'une "MsgBox" en VB6 ou à l'ocasion pouvoir y faire défiler du texte.
Comment utiliser ton code dans un prog en VB6??

j'espère que tu pourras m'aider

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.