Newsgroup: it.comp.lang.visual-basic
Titolo: [!] Bel Modulo per MsgBox

provate un po' 'sto codice, secondo me è molto molto carino    :)
Ciao
Faber
'ExtendedMsgBox-module created by the KPD-Team 2000
'URL: 
http://www.allapi.net/
'E-Mail: KPD...@Allapi.net
'HOW TO USE THIS MODULE
'-----
'SetTimeOut
'  The SetTimeOut-function enables or disables a timeout interval, thus
enabling/disabling
'  the self-closing option. The interval is measured in milliseconds.
'  Call SetTimeOut(1000)
'SetPosition
'  The SetPosition-function specifies the initial position of the messagebox
on the screen.
'  This position is measured in Pixels
'  Call SetPosition(0, 0)
'SetMessageIcon
'  The SetMessageIcon-function replaces the original Messagebox-icon with a
specified
'  picture. This function takes the handle of the Device Context from the
picture which
'  replaces the original icon.
'  Call SetMessageIcon(Picture1.hDC)
'SetButtonStyles
'  The SetButtonStyles-function sets the new style and caption for one of
the three buttons.
'  The ButtonIndex parameter must be 1, 2 or 3
'  Dim NS as tStyle
'  NS.sCaption = "Hello"
'  NS.nStyle = BS_LEFT Or BS_BOTTOM
'  NS.bNewStyle = True
'  Call SetButtonStyles(1, NS)
'SetDefaults
'  The SetDefaults-function sets the default values for each option.
'  Call SetDefaults
'ExtendedMsgBox
'  The ExtendedMsgBox-function show the modified messagebox
'  Call ExtendedMsgBox(Form1.hWnd, "Hello World!", vbOkOnly Or
vbInformation, "The Caption")
Option Explicit
'SetWindowPos public constants
Public Const SWP_NOSIZE = &H1
Public Const SWP_NOZORDER = &H4
'Button Styles
Public Const BS_PUSHBUTTON = &H0
Public Const BS_DEFPUSHBUTTON = &H1
Public Const BS_CHECKBOX = &H2
Public Const BS_AUTOCHECKBOX = &H3
Public Const BS_RADIOBUTTON = &H4
Public Const BS_3STATE = &H5
Public Const BS_AUTO3STATE = &H6
Public Const BS_GROUPBOX = &H7
Public Const BS_USERBUTTON = &H8
Public Const BS_AUTORADIOBUTTON = &H9
Public Const BS_OWNERDRAW = &HB
Public Const BS_LEFTTEXT = &H20
Public Const BS_TEXT = &H0
Public Const BS_ICON = &H40
Public Const BS_BITMAP = &H80
Public Const BS_LEFT = &H100
Public Const BS_RIGHT = &H200
Public Const BS_CENTER = &H300
Public Const BS_TOP = &H400
Public Const BS_BOTTOM = &H800
Public Const BS_VCENTER = &HC00
Public Const BS_PUSHLIKE = &H1000
Public Const BS_MULTILINE = &H2000
Public Const BS_NOTIFY = &H4000
Public Const BS_FLAT = &H8000
Public Const BS_RIGHTBUTTON = BS_LEFTTEXT
'misc. constants
Public Const WM_CLOSE = &H10
Public Const WM_PAINT = &HF
Public Const MB_CLASSNAME = "#32770"
Public Const EVENT_MSGBOXCREATE = &H1
Public Const EVENT_TIMEOUT = &H2
Public Const INIT_INTERVAL = 10
Public Const GWL_STYLE = (-16)
Public Const GWL_WNDPROC = (-4)
Public Const vbTimeOut = 200
'type for the button styles
Public Type tStyle
    sCaption As String
    nStyle As Long
    bNewStyle As Boolean
End Type
Private 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
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 FindWindow Lib "user32" Alias "FindWindowA" (ByVal
lpClassName As String, ByVal lpWindowName As String) As Long
Private Declare Function FindWindowEx Lib "user32" Alias "FindWindowExA"
(ByVal hWnd1 As Long, ByVal hWnd2 As Long, ByVal lpsz1 As String, ByVal
lpsz2 As String) 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 SetWindowText Lib "user32" Alias "SetWindowTextA"
(ByVal hwnd As Long, ByVal lpString As String) As Long
Private Declare Function GetTickCount Lib "kernel32" () As Long
Private Declare Function LockWindowUpdate Lib "user32" (ByVal hwndLock As Lo
ng) As Long
Private Declare Function GetDesktopWindow Lib "user32" () 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 Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function BitBlt Lib "gdi32" (ByVal hDestDC As Long, ByVal x
As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal
hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long)
As Long
Private Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA"
(ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal
wParam As Long, ByVal lParam As Long) As Long
Private Declare Function SetForegroundWindow Lib "user32" (ByVal hwnd As
Long) As Long
Dim sTitle As String, nTimeOut As Long, nX As Long, nY As Long, bPosChanged
As Boolean, npTime As Long
Dim ButtonStyles(1 To 3) As tStyle, hIconDC As Long, bPic As Boolean
Dim PrevProc As Long, bTimeOut As Boolean
Public Sub SetDefaults()
    nTimeOut = 0
    bPosChanged = False
    ButtonStyles(1).bNewStyle = False
    ButtonStyles(2).bNewStyle = False
    ButtonStyles(3).bNewStyle = False
    bPic = False
End Sub
Public Sub SetMessageIcon(New_IconDC As Long)
    If New_IconDC = 0 Then
        bPic = False
    Else
        hIconDC = New_IconDC
        bPic = True
    End If
End Sub
Public Sub SetButtonStyles(ButtonIndex As Integer, New_Style As tStyle)
    ButtonStyles(ButtonIndex) = New_Style
End Sub
Public Sub SetTimeOut(New_TimeOut As Long)
    nTimeOut = New_TimeOut
End Sub
Public Sub SetPosition(New_X As Long, New_Y As Long)
    If New_X = -1 Or New_Y = -1 Then
        bPosChanged = False
    Else
        nX = New_X
        nY = New_Y
        bPosChanged = True
    End If
End Sub
Public Function ExtendedMsgBox(hOwner As Long, sText As String, tStyle As
VbMsgBoxStyle, sCaption As String) As Long
    sTitle = sCaption
    LockWindowUpdate GetDesktopWindow
    SetTimer hOwner, EVENT_MSGBOXCREATE, INIT_INTERVAL, AddressOf TimerProc
    npTime = GetTickCount
    ExtendedMsgBox = MessageBox(hOwner, sText, sCaption, tStyle)
    If bTimeOut Then ExtendedMsgBox = vbTimeOut
End Function
Private Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal idEvent
As Long, ByVal dwTime As Long)
    Dim hMsgBox As Long, hButton As Long
    KillTimer hwnd, idEvent
    npTime = GetTickCount - npTime
    LockWindowUpdate False
    hMsgBox = FindWindow(MB_CLASSNAME, sTitle)
    If hMsgBox = 0 Then Exit Sub
    Select Case idEvent
        Case EVENT_MSGBOXCREATE
            If nTimeOut <> 0 Then
                SetTimer hwnd, EVENT_TIMEOUT, IIf(nTimeOut - npTime > 0,
(nTimeOut - npTime) - (npTime - INIT_INTERVAL), 1), AddressOf TimerProc
            End If
            If bPosChanged Then
                SetWindowPos hMsgBox, 0, nX, nY, 0, 0, SWP_NOSIZE Or
SWP_NOZORDER
            End If
            If ButtonStyles(1).bNewStyle = True Then
                hButton = FindWindowEx(hMsgBox, 0, "BUTTON", vbNullString)
                SetButtonStyle hButton, ButtonStyles(1).sCaption,
ButtonStyles(1).nStyle
            End If
            If ButtonStyles(2).bNewStyle = True And hButton <> 0 Then
                hButton = FindWindowEx(hMsgBox, hButton, "BUTTON",
vbNullString)
                SetButtonStyle hButton, ButtonStyles(2).sCaption,
ButtonStyles(2).nStyle
            End If
            If ButtonStyles(3).bNewStyle = True And hButton <> 0 Then
                hButton = FindWindowEx(hMsgBox, hButton, "BUTTON",
vbNullString)
                SetButtonStyle hButton, ButtonStyles(3).sCaption,
ButtonStyles(3).nStyle
            End If
            If bPic Then
                hButton = FindWindowEx(hMsgBox, 0, "STATIC", vbNullString)
                If hButton <> 0 Then
                    PrevProc = SetWindowLong(hButton, GWL_WNDPROC, AddressOf
WindowProc)
                End If
            End If
        Case EVENT_TIMEOUT
            bTimeOut = True
            SetForegroundWindow hMsgBox
            SendKeys "{enter}"
    End Select
End Sub
Private Sub SetButtonStyle(hButton As Long, nCaption As String, nStyle As
Long)
    If hButton = 0 Then Exit Sub
    Dim Ret As Long
    SetWindowText hButton, nCaption
    Ret = GetWindowLong(hButton, GWL_STYLE)
    Ret = Ret Or nStyle
    SetWindowLong hButton, GWL_STYLE, Ret
End Sub
Private Function WindowProc(ByVal hwnd As Long, ByVal uMsg As Long, ByVal
wParam As Long, ByVal lParam As Long) As Long
    If uMsg = WM_CLOSE Then
        SetWindowLong hwnd, GWL_WNDPROC, PrevProc
    End If
    WindowProc = CallWindowProc(PrevProc, hwnd, uMsg, wParam, lParam)
    If uMsg = WM_PAINT Then
        BitBlt GetDC(hwnd), 0, 0, 32, 32, hIconDC, 0, 0, vbSrcCopy
    End If
End Function

Spasmico! ;o)
U m b e r t o    M e r o n i
Software Development & Internet Services
-----------------------------------------------------
Sito servizi internet: 
http://www.ubi1k.com
Sito Visual Basic: 
http://www.vbp.it
Sito personale: 
http://www.umbertomeroni.com
-----------------------------------------------------


> Spasmico! ;o)
spasmichee?
uhmmm non c'è neanche sul traduttore di Altavista... hmmmm...
;)
Faber

 uhmmm non c'è neanche sul traduttore di Altavista... hmmmm...
*spasmico* -- agg. -- da spanciarsi fino a provocarsi spasmi cosmici.
(trad. stocast.-probabilist.-fonolog. di pAltavista)

 > uhmmm non c'č neanche sul traduttore di Altavista... hmmmm...


 Per cortesia: ogni cosa ha il suo nome!
corretto. pero', a parte che *spasmico* sarebbe attributo e non nome,
a ogni nome la sua cosa!
sullo zingarelli cartaceo ed. 1984 trovo solo:
spasimante spasimare spasimato spasimo spasimoso spasmare spasmo spasmodico
spasmofilia spasmofilo spasmolitico spasmoso.
al momento non ho i dindi per l'upgrade su cd.
a te dunque l'onere della chiosa :)
tia, pal

 a te dunque l'onere della chiosa :)
magari sta per "spam cosmico" :)
Faber


Mi togli una curiosità? Ma a cosa ti serve...

> Mi togli una curiosità? Ma a cosa ti serve...
bella domanda ehehhehe
a me piacciono le cose un po' elaborate che magari non hanno una 'vera' e
immediata utilità pratica... mi piace sapere che quando (e se) ne avrò
bisogno potrò usarlo...
cmq, a parte tutto, è un bel modulo da studiare, non credi?
Faber

Mi associo a Faber!
Umberto Meroni
umb...@vbp.it
-----------------------------------------------------
Webmaster del sito comune di it.comp.lang.visual-basic
URL Sito Comune: 
http://www.murialdo.it/it_lang_vb
-----------------------------------------------------
Sito Visual Basic: 
http://www.vbp.it
Sito Servizi Internet: 
http://www.ubi1k.com
Sito Comune VB: 
http://www.murialdo.it/it_lang_vb
-----------------------------------------------------


> cmq, a parte tutto, è un bel modulo da studiare, non credi?
Hai ragione, se si sa cos'è dov'è il bello? :-)