MsgBoxEx - Extended Message Box

[manavo11]

Based on the code from Aaron Young I found here : http://www.vbforums.com/showthread.php?t=17725,
I added some extra features :)

1) Now you can move and resize the msgbox easily.
2) Change Forecolor and Backcolor for the MsgBox.

Module Code (Post #6) : http://www.vbforums.com/showpost.php?p=2019146&postcount=6

Example (Post #7) : http://www.vbforums.com/showpost.php?p=2019151&postcount=7

[RobDog888]

Very nice additional features! Will you be fixing the button and text positioning when the msgbox is sized? ;)

[manavo11]

Very nice additional features! Will you be fixing the button and text positioning when the msgbox is sized? ;)

Thanks :) I'll be adding it shortly :)

[Hack]

I concur with RobDog. Very nice! In fact, when you finish I think I'll pop this into a modMsgBox.bas file and make it standard module for all new projects. :thumb:

[manavo11]

I concur with RobDog. Very nice! In fact, when you finish I think I'll pop this into a modMsgBox.bas file and make it standard module for all new projects. :thumb:

Thanks Hack :)

I updated the code. It resizes and moves the buttons now. I'm sure it's not perfect so I'm open to suggestions :)

[manavo11]

In a standard module :

'*************************************************************
'* MsgBoxEx() - Written by Aaron Young, February 7th 2000
'* - Edited by Philip Manavopoulos, May 19th 2005
'*************************************************************

Option Explicit

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

'Added by manavo11
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type

Private Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
'Added by manavo11

Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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 CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook 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 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 SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long

'Added by manavo11
Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Private Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long

Private Declare Function SetFocus Lib "user32" (ByVal hwnd As Long) As Long

Private Declare Function MoveWindow Lib "user32" (ByVal hwnd As Long, ByVal X As Long, ByVal Y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal bRepaint As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetClientRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) 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
'Added by manavo11

Private Const WH_CALLWNDPROC = 4
Private Const GWL_WNDPROC = (-4)
Private Const WM_CTLCOLORBTN = &H135
Private Const WM_DESTROY = &H2
Private Const WM_SETTEXT = &HC
Private Const WM_CREATE = &H1

'Added by manavo11
' System Color Constants
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18

' Windows Messages
Private Const WM_CTLCOLORSTATIC = &H138
Private Const WM_CTLCOLORDLG = &H136

Private Const WM_SHOWWINDOW As Long = &H18
'Added by manavo11

Private lHook As Long
Private lPrevWnd As Long

Private bCustom As Boolean
Private sButtons() As String
Private lButton As Long
Private sHwnd As String

'Added by manavo11
Private lForecolor As Long
Private lBackcolor As Long

Private sDefaultButton As String

Private iX As String
Private iY As String
Private iWidth As String
Private iHeight As String

Private iButtonCount As Integer
Private iButtonWidth As Integer
'Added by manavo11

Public Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim sText As String

Select Case Msg

'Added by manavo11
Case WM_SHOWWINDOW
Dim MsgBoxRect As RECT

GetWindowRect hwnd, MsgBoxRect

If StrPtr(iX) = 0 Then
iX = MsgBoxRect.Left
End If

If StrPtr(iY) = 0 Then
iY = MsgBoxRect.Top
End If

If StrPtr(iWidth) = 0 Then
iWidth = MsgBoxRect.Right - MsgBoxRect.Left
Else
Dim i As Integer
Dim h As Long

Dim ButtonRECT As RECT

For i = 0 To iButtonCount
h = FindWindowEx(hwnd, h, "Button", vbNullString)

GetWindowRect h, ButtonRECT

MoveWindow h, 14 + (iButtonWidth * i) + (6 * i), iHeight - (ButtonRECT.Bottom - ButtonRECT.Top) - 40, iButtonWidth, ButtonRECT.Bottom - ButtonRECT.Top, 1
Next
End If

If StrPtr(iHeight) = 0 Then
iHeight = MsgBoxRect.Bottom - MsgBoxRect.Top
End If

MoveWindow hwnd, iX, iY, iWidth, iHeight, 1
Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC
Dim tLB As LOGBRUSH
'Debug.Print wParam

Call SetTextColor(wParam, lForecolor)
Call SetBkColor(wParam, lBackcolor)

tLB.lbColor = lBackcolor

SubMsgBox = CreateBrushIndirect(tLB)
Exit Function
'Added by manavo11

Case WM_CTLCOLORBTN
'Customize the MessageBox Buttons if neccessary..
'First Process the Default Action of the Message (Draw the Button)
SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
'Now Change the Button Text if Required
If Not bCustom Then Exit Function
If lButton = 0 Then sHwnd = ""
'If this Button has Been Modified Already then Exit
If InStr(sHwnd, " " & Trim(Str(lParam)) & " ") Then Exit Function
sText = sButtons(lButton)
sHwnd = sHwnd & " " & Trim(Str(lParam)) & " "
lButton = lButton + 1
'Modify the Button Text
SendMessage lParam, WM_SETTEXT, Len(sText), ByVal sText

'Added by manavo11
If sText = sDefaultButton Then
SetFocus lParam
End If
'Added by manavo11

Exit Function

Case WM_DESTROY
'Remove the MsgBox Subclassing
Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
End Select
SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function

Private Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tCWP As CWPSTRUCT
Dim sClass As String
'This is where you need to Hook the Messagebox
CopyMemory tCWP, ByVal lParam, Len(tCWP)
If tCWP.message = WM_CREATE Then
sClass = Space(255)
sClass = Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
If sClass = "#32770" Then
'Subclass the Messagebox as it's created
lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf SubMsgBox)
End If
End If
HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
End Function

Public Function MsgBoxEx(ByVal Prompt As String, Optional ByVal Buttons As Long = vbOKOnly, Optional ByVal Title As String, Optional ByVal HelpFile As String, Optional ByVal Context As Long, Optional ByRef CustomButtons As Variant, Optional DefaultButton As String, Optional X As String, Optional Y As String, Optional Width As String, Optional Height As String, Optional ByVal ForeColor As ColorConstants = -1, Optional ByVal BackColor As ColorConstants = -1) As Long
Dim lReturn As Long

bCustom = (Buttons = vbCustom)
If bCustom And IsMissing(CustomButtons) Then
MsgBox "When using the Custom option you need to supply some Buttons in the ""CustomButtons"" Argument.", vbExclamation + vbOKOnly, "Error"
Exit Function
End If
lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, App.hInstance, App.ThreadID)
'Set the Defaults
If Len(Title) = 0 Then Title = App.Title
If bCustom Then
'User wants to use own Button Titles..
If TypeName(CustomButtons) = "String" Then
ReDim sButtons(0)
sButtons(0) = CustomButtons
Buttons = 0
Else
sButtons = CustomButtons
Buttons = UBound(sButtons)
End If
End If

'Added by manavo11
lForecolor = GetSysColor(COLOR_BTNTEXT)
lBackcolor = GetSysColor(COLOR_BTNFACE)

If ForeColor >= 0 Then lForecolor = ForeColor
If BackColor >= 0 Then lBackcolor = BackColor

sDefaultButton = DefaultButton

iX = X
iY = Y
iWidth = Width
iHeight = Height

iButtonCount = UBound(sButtons)
iButtonWidth = (iWidth - (2 * 14) - (6 * (Buttons + 1))) / (Buttons + 1)
'Added by manavo11

lButton = 0

'Show the Modified MsgBox
lReturn = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
Call UnhookWindowsHookEx(lHook)
'If it's a Custom Button MsgBox, Alter the Return Value
If bCustom Then lReturn = lReturn - (UBound(CustomButtons) + 1)
bCustom = False
MsgBoxEx = lReturn
End Function

[manavo11]

Example :

Private Sub Command1_Click()
Dim aButtons(2) As String
aButtons(0) = "Go"
aButtons(1) = "Come"
aButtons(2) = "???"

Caption = aButtons(MsgBoxEx("Text" & vbCrLf & "More Text" & vbCrLf & "Even More Text", vbCustom, "Title", , , aButtons, aButtons(1), 0, 0, 200, 300, vbWhite, vbBlue))
End Sub

[claudiolins]

Can we have a background picture on it ?

[manavo11]

Well, in theory you should be able to, although I haven't tried it... Probably when the same message is called when you set the background color, instead of calling the SetBkColor API, you could call the BitBlt, right? Both take the hdc as a parameter to draw on. So I'm guessing it's possible, but not implemented in the above code :)

[Liquid Metal]

manavo11, if you get a chance, can you post your code in VB tags? When I copy your code and past it to a module, it is all bunch up on couple lines.

Thank You

[lintz]

Liquid Metal, I read a post that said to copy code (within VB tags) click the 'Quote' button which removes all the line numbers allowing you to copy and paste the code into your project :thumb:

[RobDog888]

Or check out MartinLiss' signature for his VB Code Copier fix.

[dilettante]

How close does it get us to TaskDialog()'s functionality?

So long MessageBox and thanks for all the memories (http://shellrevealed.com/blogs/shellblog/archive/2006/09/19/So-long-MessageBox-and-thanks-for-all-the-memories.aspx)

[Liquid Metal]

Liquid Metal, I read a post that said to copy code (within VB tags) click the 'Quote' button which removes all the line numbers allowing you to copy and paste the code into your project :thumb:I just clicked the Quote button on you and it worked!:D:p Thanks for the tip Lintz, it was good.:thumb: :cool: :afrog:

[lintz]

Glad to help :wave: :D

[Zach_VB6]

I got a question:

Public Function MsgBoxEx(ByVal Prompt As String, Optional ByVal Buttons As Long = vbOKOnly, Optional ByVal Title As String, Optional ByVal HelpFile As String, Optional ByVal Context As Long, Optional ByRef CustomButtons As Variant, Optional DefaultButton As String, Optional X As String, Optional Y As String, Optional Width As String, Optional Height As String, Optional ByVal ForeColor As ColorConstants = -1, Optional ByVal BackColor As ColorConstants = -1) As Long

Can't the bolded strings be integers?

[RobDog888]

Where is the bolded parts? It doesnt show.

[techgnome]

I think it was in ref to this part ( the bold is hard to see, so I also changed the color)

Optional X As String, Optional Y As String, Optional Width As String, Optional Height As String

Doesn't it make sense to make those Longs instead?

-tg

[RobDog888]

Yes, if your passing numerical data all the time, as in coordinates, then it does make logical sense to change the signature to Integer or Long instead.

[techgnome]

:) Well, I'm think that until VB recognizes "four hundred fifty-eight" as a number.... it's pretty safe (possibly safer) to change it to longs to allow 458...

:)

-tg

[TheVBshark]

nice coding but cant we increase the font size......please

[levanduyet]

Dear All,

These code can not show the Unicode message.

LVD