قرار دادن Msgbox در وسط فرم

[M.T.P]

دوستانی که از تابع Msgbox استفاده کردن میدونن که این پیغام همیشه در وسط صفحه نمایش ظاهر میشه و کاری به فرم برنامه ما نداره ، چطور این پیغام را به مرکز فرم خود منتقل کنیم البته در حین اجرا؟:متفکر:

[M.T.P]

با اینکه مدت زیادی از تاریخ تاپیک گذشته... اما بالاخره بی جواب مونده و نهایتا جوابش رو پیدا کردم.

کد استفاده:

MessageBox "hello user !", vbInformation

کد ماژول:


Option Explicit

'////////////////////////////////////////////////
'Writen by mansour torkashvand
'mtpsoft.ir
'mtpsoftwares@yahoo.com
'Last update: 1391/4/14
'////////////////////////////////////////////////

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

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 plMsgHook As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hWnd As Long, lpRect As RECT) As Long
Private Declare Function GetParent 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 Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5

Private hHook As Long

Public Function MessageBox(Prompt, _
Optional Buttons As VbMsgBoxStyle = vbInformation, _
Optional Title) As VbMsgBoxResult

hHook = SetWindowsHookEx(WH_CBT, _
AddressOf MsgCallBack, _
App.hInstance, _
App.ThreadID)

MessageBox = MsgBox(Prompt, Buttons, Title)
End Function

Private Function MsgCallBack(ByVal lMsg As Long, _
ByVal wParam As Long, _
ByVal lParam As Long) As Long

Dim tRectOwner As RECT
Dim tRectMsgBox As RECT
Dim lxPos As Long
Dim lyPos As Long

'wParam = handle to msgbox
If lMsg = HCBT_ACTIVATE Then

If GetParent(wParam) Then

GetWindowRect GetParent(wParam), tRectOwner
GetWindowRect wParam, tRectMsgBox

'if Parent not minimized
If tRectOwner.Left > 0 Then

'Determine x and y
lxPos = (tRectOwner.Left + _
(tRectOwner.Right - tRectOwner.Left) / 2) - _
((tRectMsgBox.Right - tRectMsgBox.Left) / 2)

lyPos = (tRectOwner.Top + _
(tRectOwner.Bottom - tRectOwner.Top) / 2) - _
((tRectMsgBox.Bottom - tRectMsgBox.Top) / 2)

MoveWindow wParam, lxPos, lyPos, _
tRectMsgBox.Right - tRectMsgBox.Left, _
tRectMsgBox.Bottom - tRectMsgBox.Top, True

End If

End If

'Release the hook
UnhookWindowsHookEx hHook
End If

MsgCallBack = False

End Function

[vbhamed]

سلام

اينم ساده ترش، ضمنا مي تونه بعد از زمان مشخص شده خودش پنجره رو ببنده

كد ماژول :

Public Const MAX_PATH As Long = 260&
Public Const API_FALSE As Long = 0&
Public Const NV_CLOSEMSGBOX As Long = &H5000&
Public Const NV_MOVEMSGBOX As Long = &H5001&
Public Const MB_ICONQUESTION As Long = &H20&
Public Const MB_TASKMODAL As Long = &H2000&
Public Const SWP_NOSIZE As Long = &H1&
Public Const SWP_NOZORDER As Long = &H4&
Public Const HWND_TOP As Long = 0&

Type RECT

Left As Long
Top As Long
Right As Long
Bottom As Long

End Type

Public Declare Function LockWindowUpdate& Lib "user32" (ByVal hwndLock&)
Public Declare Function GetActiveWindow& Lib "user32" ()
Public Declare Function GetDesktopWindow& Lib "user32" ()
Public Declare Function FindWindow& Lib "user32" Alias "FindWindowA" (ByVal lpClassName$, ByVal lpWindowName$)
Public Declare Function SetForegroundWindow& Lib "user32" (ByVal hWnd&)
Public Declare Function GetClassName& Lib "user32" Alias "GetClassNameA" (ByVal hWnd&, ByVal lpClassName$, ByVal nMaxCount&)
Public Declare Function GetWindowRect& Lib "user32" (ByVal hWnd&, lpRect As RECT)
Public Declare Function SetWindowPos& Lib "user32" (ByVal hWnd&, ByVal hWndInsertAfter&, ByVal x&, ByVal y&, ByVal cx&, ByVal cy&, ByVal wFlags&)
Public Declare Function MessageBox& Lib "user32" Alias "MessageBoxA" (ByVal hWnd&, ByVal lpText$, ByVal lpCaption$, ByVal wType&)
Public Declare Function SetTimer& Lib "user32" (ByVal hWnd&, ByVal nIDEvent&, ByVal uElapse&, ByVal lpTimerFunc&)
Public Declare Function KillTimer& Lib "user32" (ByVal hWnd&, ByVal nIDEvent&)

Public Sub TimerProc(ByVal hWnd&, ByVal uMsg&, ByVal idEvent&, ByVal dwTime&)

KillTimer hWnd, idEvent

Select Case idEvent

Case NV_CLOSEMSGBOX '<-- we want to close this messagebox after 4 seconds
Dim hMessageBox&

hMessageBox = FindWindow("#32770", "Self Closing Message Box")

If hMessageBox Then
Call SetForegroundWindow(hMessageBox)
SendKeys "{enter}"
End If

Case NV_MOVEMSGBOX '<-- we want to move this messagebox
Dim hMsgBox&, xPoint&, yPoint&
Dim stMsgBoxRect As RECT, stParentRect As RECT

hMsgBox = FindWindow("#32770", "Position A Message Box")

If hMsgBox Then

Call GetWindowRect(hMsgBox, stMsgBoxRect)
Call GetWindowRect(hWnd, stParentRect)

xPoint = stParentRect.Left + (((stParentRect.Right - stParentRect.Left) _
\ 2) - ((stMsgBoxRect.Right - stMsgBoxRect.Left) \ 2))
yPoint = stParentRect.Top + (((stParentRect.Bottom - stParentRect.Top) _
\ 2) - ((stMsgBoxRect.Bottom - stMsgBoxRect.Top) \ 2))

Call SetWindowPos(hMsgBox, HWND_TOP, xPoint, yPoint, API_FALSE, _
API_FALSE, SWP_NOZORDER Or SWP_NOSIZE)
End If

' unlock the desktop
Call LockWindowUpdate(API_FALSE)

End Select

End Sub



اينم روش استفاده، دو تا دكمه رو فرم بزاريد

Private Sub Command1_Click()

' this shows a messagebox that will be dismissed after 4 seconds
' set the callback timer and pass our application defined ID (NV_CLOSEMSGBOX)
' set the time for 4 seconds (4000& microseconds)
SetTimer hWnd, NV_CLOSEMSGBOX, 4000&, AddressOf TimerProc

' call the messagebox API function
Call MessageBox(hWnd, "Watch this message box close itself after four seconds", _
"Self Closing Message Box", MB_ICONQUESTION Or MB_TASKMODAL)

End Sub

Private Sub Command2_Click()

' this positions the messagebox in the desired location on the screen.
' the location is defined in the callback timer function

' lock the desktop so that the initial position is not shown
Call LockWindowUpdate(GetDesktopWindow())

' set the callback timer with our application defined ID (NV_MOVEMSGBOX)
' set the time for 10 microseconds to allow the messagebox time to become active
SetTimer hWnd, NV_MOVEMSGBOX, 10&, AddressOf TimerProc

' call the messagebox API function
Call MessageBox(hWnd, "message box in't in the middle of the screen?", _
"Position A Message Box", MB_ICONQUESTION Or MB_TASKMODAL)

End Sub

[vbhamed]

سلام

البته اگر فقط وسط بودن مورد نظر هست يك راه ساده تر و جالب تر هم وجود داره

كد ماژول


Option Explicit

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

Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal plMsgHook 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 GetCurrentThreadId Lib "kernel32" () 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 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 GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long

Private Const GWL_HINSTANCE = (-6)
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Private Const SWP_NOACTIVATE = &H10
Private Const HCBT_ACTIVATE = 5
Private Const WH_CBT = 5

Private plMsgHook As Long

Public Function CenterMessageBox(frmHwnd As Long)

Dim lInstance As Long
Dim lThreadID As Long

lInstance = GetWindowLong(frmHwnd, GWL_HINSTANCE)
lThreadID = GetCurrentThreadId()
plMsgHook = SetWindowsHookEx(WH_CBT, AddressOf CenterMsgCallBack, lInstance, lThreadID)

End Function

Private Function CenterMsgCallBack(ByVal lMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long

Dim typFormRect As RECT
Dim typRectMsg As RECT
Dim lxPos As Long, lyPos As Long

If lMsg = HCBT_ACTIVATE Then
GetWindowRect Form1.hwnd, typFormRect
GetWindowRect wParam, typRectMsg

lxPos = (typFormRect.Left + (typFormRect.Right - typFormRect.Left) / 2) - ((typRectMsg.Right - typRectMsg.Left) / 2)
lyPos = (typFormRect.Top + (typFormRect.Bottom - typFormRect.Top) / 2) - ((typRectMsg.Bottom - typRectMsg.Top) / 2)

SetWindowPos wParam, 0, lxPos, lyPos, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_NOACTIVATE

UnhookWindowsHookEx plMsgHook
End If

CenterMsgCallBack = False

End Function


روش استفاده، فقط كافيه تابع رو دقيقا قبل از MSGBOX فراخواني كنيد و hwnd فرمي كه بايد msgbox وسطش باشه رو بهش بدين

CenterMessageBox Me.hwnd
MsgBox "test", vbYesNoCancel, "Test"