*كود* جعل Msgbox تملئ الشاشة

لجعل مربع الحوار Msgbox يملئ الشاشة استخدم الكود التالي :

في الوحدة النمطية العامة ضع :

Declare Function SetActiveWindow Lib "user32" _
 (ByVal hwnd As Long) As Long
Declare Function SetTimer Lib "user32" (ByVal hwnd _
 As Long, ByVal nIDEvent As Long, ByVal uElapse _
 As Long, ByVal lpTimerFunc As Long) As Long
Declare Function KillTimer Lib "user32" _
(ByVal hwnd As Long, ByVal nIDEvent As Long) _
As Long
Declare Function FindWindowEx Lib "user32" _
 Alias "FindWindowExA" (ByVal hWndParent As _
 Long, ByVal hWndChildAfter As Long, ByVal _
 lpClassName As String, ByVal lpWindowName _
 As String) As Long
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
Public str_Title$, TimerId&

Sub TimerProc(ByVal hwnd As Long, ByVal uMsg As Long, _
 ByVal uElapse As Long, ByVal lpTimerFunc As Long)
 KillTimer Screen.ActiveForm.hwnd, TimerId
 Dim lng_Hwnd&
 lng_Hwnd = FindWindowEx(0, 0, "#32770", _
  Trim(str_Title))
 If lng_Hwnd Then
  SetActiveWindow lng_Hwnd
'  MoveWindow lng_Hwnd, 0, 0, Screen.Width / 15, _
  Screen.Height / 15, 1
    MoveWindow lng_Hwnd, 0, 0, 12000 / 15, _
  9000 / 15, 1

 End If
End Sub

وفي حدث نقر زر أمر مثلا ضع :

Dim str As String
TimerId = SetTimer(Me.hwnd, 0, 1, AddressOf TimerProc)
str_Title = "مع تحيات الفريق العربي للبرمجة"
str = "قال رسول الله صلى الله عليه وسلم ((أحب الناس إلى الله أنفعهم، وأحب الأعمال إلى الله عز وجل سرور" _
& " تدخله على مسلم، أو تكشف عنه كربة، أو تقضي عنه ديناً، أو تطرد عنه جوعاً،" _
& " ولأن أمشي مع أخي المسلم في حاجة أحب إلي من أن أعتكف في المسجد شهراً،" _
& " ومن كف غضبه، ستر الله عورته، ومن كظم غيظاً، ولو شاء أن يمضيه أمضاه،" _
& " ملأ الله قلبه رضى يوم القيامة، ومن مشى مع أخيه المسلم في حاجته حتى يثبتها له، أثبت" _
& " الله تعالى قدمه يوم تزال الأقدام، وإن سوء الخلق ليفسد العمل، كما يفسد الخل العسل)) . "

MsgBox str & vbCrLf & "مربع اخراج بأبعاد الشاشة" & vbCrLf & "الكود من إعداد /" & _
vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & vbCrLf & _
"Read Only", vbMsgBoxRight + vbMsgBoxRtlReading, str_Title

KillTimer Me.hwnd, 0

علماً أن الكود هو من الأخ Read Only وقد عملت عليه بعض التعديلات ليعمل في الأكسس ، وهذا رابط الموضوع الأصلي :

http://arabteam.nicmatic.com/vb/showthread...35614#post35614

وللجميع التحية

كود جعل Msgbox تملئ الشاشة

مواضيع مشابهة