サンプル投稿用掲示板 VB2005 〜 用トップページ VB6.0 用 トップページ
- 日時： 2007/07/15 18:43
- 名前： 花ちゃん
- ***********************************************************************************
* カテゴリー：[メッセージ][][] *
* キーワード：自動的,クリック,閉じる,ボタンをクリック,, *
***********************************************************************************
-----------------------------------------------------------------------------------
No.1828 Re：メッセージボックスの強制終了 投稿者：ゆう(U) [2001/02/06(火)17：54分]
-----------------------------------------------------------------------------------
●ゆー太郎 さんの言われる通り専用のフォームを用意す(造)るのが一番安全かつ確実です。
勧めしない方法ですが・・・
[CLSMSGBOXAA.CLS]
Option Explicit
'==========================================================
'自動解答付きMsgBoxクラス
'==========================================================
'////////////////////////////////
'// Timerコントロールが必要です //
'///////////////////////////////
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 SendMessage Lib "user32" _
Alias "SendMessageA" _
(ByVal hWnd As Long, _
ByVal wMsg As Long, _
ByVal wParam As Long, _
ByRef lParam As Any) As Long
Private Declare Function SetWindowText Lib "user32" _
Alias "SetWindowTextA" _
(ByVal hWnd As Long, _
ByVal lpString As String) As Long
Private Declare Function timeGetTime Lib "winmm.dll" _
() As Long
Private hMsgBox As Long
Private strCaption As String
Private lngLimit As Long
Private blnInit As Boolean
Private varArray As Variant
Private lngArrayCount As Long
Private lngButtonNumber As Long
Private WithEvents myTimer As Timer
'==========================================================
'自動解答付きMsgBox関数 MsgBox
'==========================================================
' result = MsgBox(Prompt, [Buttons], [Title], [ButtonsCap], _
' [MilliSecond], [ButtonMumber])
' 引数 Prompt ：MsgBoxと同じ
' Buttons ：MsgBoxと同じ
' Title ：MsgBoxと同じ
' ButtonsCap ：変更時のボタンキャプチャ
' MilliSecond ：自動解答までの秒数(ミリ秒・動作最小値は60?)
' ButtonNumber：自動解答時のボタン番号(最小値=０：最左)
'----------------------------------------------------------
' 注意 IDEでは正常に(意図した)動作しません。
' Timerイベントのバグ(?)を利用した機能なので動作確認は
' 十分に行って使用下さい。
' ボタン幅は変更していませんので、文字数に注意して下さい。
'----------------------------------------------------------
'例
' Dim cMsgBox As New clsMsgBoxAA
' dim lngResult As Long
' Set cMsgBox.Timer = Timer1
' lngResult = cMsgBox.MsgBox("Hello", _
' vbYesNoCancel Or vbDefaultButton1, _
' "TiTle", _
' Array("はい(&Y)", "いいえ(&N)", "中止(&C)"), _
' 2000, _
' 2)
'----------------------------------------------------------
Public Function MsgBox(ByRef Prompt As String, _
Optional ByVal Buttons As _
VbMsgBoxStyle = vbOKOnly, _
Optional ByRef Title As Variant, _
Optional ByRef ButtonsCap As Variant, _
Optional ByVal MilliSecond As _
Long = 5000&, _
Optional ByVal ButtonNumber As _
Long = 0 _
) As VbMsgBoxResult
If TypeName(myTimer) = "Nothing" Then
VBA.MsgBox "Timerが設定されていません", vbCritical
Err.Raise 17
Exit Function
End If
If IsMissing(Title) Then
strCaption = App.Title
Else
strCaption = Title
End If
If Not IsMissing(ButtonsCap) Then
varArray = ButtonsCap
lngArrayCount = UBound(varArray) - LBound(varArray) + 1
End If
lngButtonNumber = ButtonNumber
lngLimit = timeGetTime + MilliSecond
blnInit = True
With myTimer
.Interval = 50
.Enabled = True
MsgBox = VBA.MsgBox(Prompt, Buttons, Title)
.Enabled = False
End With
End Function
Private Sub myTimer_Timer()
Const WM_LBUTTONDOWN = &H201& '左のマウスボタンを押した
Const WM_LBUTTONUP = &H202& '左のマウスボタンを離した
Const MK_LBUTTON = &H1& '左のマウスボタンが押されている
Dim i As Long
Dim hButton As Long
If blnInit Then
hMsgBox = FindWindowEx(0, 0, "#32770", strCaption)
If hMsgBox = 0 Then Exit Sub
For i = 0 To lngArrayCount - 1
hButton = FindWindowEx(hMsgBox, hButton, "Button", vbNullString)
Call SetWindowText(hButton, CStr(varArray(i)) & vbNullChar)
Next
blnInit = False
Else
If lngLimit < timeGetTime Then
For i = 0 To lngButtonNumber
hButton = FindWindowEx(hMsgBox, hButton, "Button", vbNullString)
Next
Call SendMessage(hButton, WM_LBUTTONDOWN, MK_LBUTTON, ByVal 0&)
Call SendMessage(hButton, WM_LBUTTONUP, 0&, ByVal 0&)
End If
End If
End Sub
Public Property Set msgTimer(ByRef msgTimer As Timer)
If TypeOf msgTimer Is Timer Then
Set myTimer = msgTimer
End If
End Property
Private Sub Class_Terminate()
Set myTimer = Nothing
End Sub
無理やりこんなこともできます。
※動作確認はしっかり行ってください
どのような結果になっても私は責任持ちません
 |
メッセージボックスの強制終了(VB6.0)_1