VB实现非模式对话框

[xhzhuzz]

请问,如何用VB实现非模式对话框,该对话框可以实现倒计时,时间到就自动关闭

[lyserver]

最好使用Form进行模拟，经毕竟对话框也是一种窗口。如果不想模拟，可以使用对话框资源，由于VB不直接支持对话框资料，需要用VC将对话框资源编译进一个DLL里，然后使用API进行调用，至少调用的代码，网上许多，俺给你复制一个现成的。

Option Explicit

Private Declare Function LoadLibrary Lib "kernel32.dll" Alias "LoadLibraryA" (ByVal lpLibFileName As String) As Long
Public Declare Function FreeLibrary Lib "kernel32.dll" (ByVal hLibModule As Long) As Long
Public Declare Function CreateDialogParam Lib "user32.dll" Alias "CreateDialogParamA" (ByVal hInstance As Long, ByVal lpName As Long, ByVal hWndParent As Long, ByVal lpDialogFunc As Long, ByVal lParamInit As Long) As Long
Public Const SW_SHOW As Long = 5
Public Declare Function ShowWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal nCmdShow As Long) As Long
Public Const WM_SYSCOMMAND As Long = &H112
Public Const SC_CLOSE As Long = &HF060&
Public Declare Function EndDialog Lib "user32.dll" (ByVal hDlg As Long, ByVal nResult As Long) As Long
Public Declare Function GetMessage Lib "user32.dll" Alias "GetMessageA" (ByRef lpMsg As MSG, ByVal hwnd As Long, ByVal wMsgFilterMin As Long, ByVal wMsgFilterMax As Long) As Long
Public Declare Function TranslateMessage Lib "user32.dll" (ByRef lpMsg As MSG) As Long
Public Declare Function DispatchMessage Lib "user32.dll" Alias "DispatchMessageA" (ByRef lpMsg As MSG) As Long
Public Declare Sub PostQuitMessage Lib "user32.dll" (ByVal nExitCode As Long)
Public Type POINTAPI
    x As Long
    y As Long
End Type
Public Type MSG
    hwnd As Long
    message As Long
    wParam As Long
    lParam As Long
    time As Long
    pt As POINTAPI
End Type

Public Function DialogProc(ByVal hwndDlg&, ByVal uMsg&, ByVal wParam&, ByVal lParam&) As Long
    If uMsg = WM_SYSCOMMAND Then
        If wParam = SC_CLOSE Then
            Call EndDialog(hwndDlg, 0)
            PostQuitMessage 0
            DialogProc = 0
        End If
    End If
End Function

Public Sub Main()
    Dim hDlg As Long
    Dim tMsg As MSG
    Dim hIns As Long
    
    hIns = LoadLibrary("shdoclc.dll")
    hDlg = CreateDialogParam(hIns, 24581, 0, AddressOf DialogProc, 0)
    FreeLibrary hIns

    ShowWindow hDlg, SW_SHOW

    While GetMessage(tMsg, 0, 0, 0)
        Call TranslateMessage(tMsg)
        Call DispatchMessage(tMsg)
    Wend
End Sub

上面的代码调用IE的一个DLL里的对话框资源，需要说明的是，建议将程序编译后运行，否则容易导致VB开发环境崩溃。

[白发程序猿]

用窗体模拟不是很好吗？

[Tiger_Zhao]

'窗体上添加一个 Label、一个 ProgressBar、一个 CommandButton（Name = cmdOK）
Option Explicit

Private Sub cmdOK_Click()
    Unload Me
End Sub

Private Sub Form_Load()
    With ProgressBar1
        .Min = 0
        .Max = 30
        .Value = 0
        Label1.Caption = "还有 " & (.Max - .Value) & " 秒自动关闭。"
    End With
    Timer1.Interval = 1000
    Timer1.Enabled = True
End Sub

Private Sub Timer1_Timer()
    With ProgressBar1
        .Value = .Value + 1
        Label1.Caption = "还有 " & (.Max - .Value) & " 秒自动关闭。"
        
        If .Value = .Max Then
            Timer1.Enabled = False
            Call cmdOK_Click
        End If
    End With
End Sub

[happy_sea]

既然是得倒计时，那么当然需要在对话框上实时显示剩余时间，这个用普通的对话框是难以实现的，就用楼上的方法使用窗体模拟一个好了。

[of123]

'在表单的声明区中加入以下的声明

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
(ByVal lpClassName As String, ByVal lpWindowName As String) 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 Const WM_CLOSE = &H10
Private Const MsgTitle As String = "Test Message"

'在表单中加入一个 CommandButton 及一个 Timer 控制项，加入以下程序码：

Private Sub Command1_Click()
Dim nRet As Long
Timer1.Interval = 3000
Timer1.Enabled = True
nRet = MsgBox("若您不回应的话，3 秒后此 MsgBox 会自动关闭", 64, MsgTitle)
Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
Dim hWnd As Long
hWnd = FindWindow(vbNullString, MsgTitle)
Call SendMessage(hWnd, WM_CLOSE, 0, ByVal 0&)
End Sub


注意：此方法的限制说明：

1、当常数设定为 VbAbortRetryIgnore 或 VbYesNo 时，无效！
2、在 Design Time 时，无效，必须 Make EXE 之后才有效！

[Tiger_Zhao]

不能从模态窗体打开非模态窗体，这是规则。

[of123]

你不是要做定时对话框吗？跟非模式窗体扯什么？

[东方之珠]

非模态窗口msgbox是可以做到倒计时的:

Option Explicit

Private Sub Command1_Click()
        CreateObject("Wscript.Shell").Popup "本窗口将在三秒钟后自动关闭……", 3, "MsgBox", 64
End Sub

[东方之珠]

这种方法也很绝妙,利用MessageBox函数:

Option Explicit

'Form1上添加一个Command1、一个Timer1

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) 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 MessageBox Lib "user32" Alias "MessageBoxA" (ByVal hwnd As Long, ByVal lpText As String, ByVal lpCaption As String, ByVal wType As Long) As Long
Private Const WM_CLOSE = &H10
Private Const MsgTitle As String = "Test Message"
Dim TestHwnd As Long
Private Sub Command1_Click()
   Timer1.Interval = 3000
   Timer1.Enabled = True
   MessageBox Me.hwnd, "如果您不回应的话，本窗口 3 秒钟后此 MsgBox 会自动关闭", MsgTitle, 64
   Timer1.Enabled = False
End Sub

Private Sub Timer1_Timer()
        TestHwnd = FindWindow(vbNullString, MsgTitle)
        If TestHwnd > 0 Then Call SendMessage(TestHwnd, WM_CLOSE, 0, ByVal 0&)
End Sub

[xhzhuzz]

我的目的是单击窗体上的某个按钮时，出现提示框，提示框可以到计时，计时到，则提示框自动消失，在这个时间内我可以做一些事情，比如填写窗体上的TEXT,也就是提示框可以置顶，不 影响其他的动作

[clear_zero]

那你就做个picturebox或者frame

点按钮--〉frame显示，timer启动-->到事件了--〉frame消失

[xhzhuzz]

大家的方法可以出现提示框，可是我想在这个时间内完成比如录入工作，就要先关闭提示框，我 的意思是边录入，一边进行提示，时间到就自己关闭，不 用去点确定

[xhzhuzz]

我已经有一个窗体,我现在要显示新建的这个窗体(FORM4),怎么提示"当打开模式窗体时不能显示模式窗体"
Private Sub Command1_Click()
Form4.Show
End Sub

[clear_zero]

我的回复呢？

[Tiger_Zhao]

那就改用状态条提示。

行人靠右行还是靠左行并不存在优劣，完全是习惯性的约定。如果不希望你的程序行为怪异，就不要轻易改变对话框的约定特性。

[lili830209]

不懂，帮顶

[hbwhwc]

不懂，帮顶

[crazyhouse]

9楼牛,非常强大