- UID
- 7437
- 精华
- 积分
- 1149
- 威望
- 点
- 宅币
- 个
- 贡献
- 次
- 宅之契约
- 份
- 最后登录
- 1970-1-1
- 在线时间
- 小时
|
发表于 2024-11-4 13:24:48
|
显示全部楼层
本帖最后由 tlwh163 于 2024-11-4 13:33 编辑
我认真学习了楼主的思想 然后自己查了些资料 也学着写了一个
是用 VisualFreeBasic 5.9.3 写的, 请指教!
''=========================================================================================
'' 高仿VB6输入框
''=========================================================================================
'' 在对话框中显示提示,等待用户输入正文或按下按钮,并返回包含文本框内容的字符串表达式;
'' 如果用户单击 确定 或 按下ENTER, 则返回文本框中的内容(缓冲区长度260字符);
'' 如果用户单击 取消 或 按下ESC, 则返回长度为零的字符串("");
'' -----------------------------------------------------------------------------------
'' InputBox([hParent], Prompt[, Title] [, Default] [, xPos] [, yPos] [, HelpFile, Context])
'' InputBoxW() 需要辅助函数 InputBoxWndProcW() 协同工作
'' -----------------------------------------------------------------------------------
'' hParent: 可选的, 数值表达式, 指定对话框的拥有者窗体句柄(如果省略则把桌面窗体作为对话框拥有者)
'' Prompt: 必需的, 字符串表达式, 显示在对话框的消息标签中
'' Title: 可选的, 字符串表达式, 显示在对话框标题栏中(如果省略则把应用程序名放入标题栏)
'' Default: 可选的, 字符串表达式, 显示在文本框中,在没有其它输入时作为缺省值
'' xPos: 可选的, 数值表达式, 与yPos成对出现,指定对话框的水平位置(如果省略,则对话框会在水平方向居中)
'' yPos: 可选的, 数值表达式, 与xPos成对出现,指定对话框的垂直位置(如果省略,则对话框会在垂直方向居中)
'' Helpfile: 可选的, 字符串表达式, 识别帮助文件,用该文件为对话框提供上下文相关的帮助(必须同时提供Context)
'' Context: 可选的, 数值表达式, 由帮助文件的作者指定给某个帮助主题的帮助上下文编号(必须同时提供HelpFile)
''=========================================================================================
Function InputBoxWndProcW(ByVal hWnd As HWND, ByVal uMsg As UINT, ByVal wParam As WPARAM, ByVal lParam As LPARAM) As LResult
Dim wResult As Any Ptr = 0
Select Case uMsg
Case WM_DESTROY
RemovePropW(hWnd, "_ResultValue")
PostQuitMessage(0) '使InputBox窗口的内部消息循环退出
Case WM_KEYDOWN
If wParam = VK_RETURN Then Return SendMessageW(hWnd, WM_COMMAND, IDOK, 0)
If wParam = VK_ESCAPE Then Return SendMessageW(hWnd, WM_COMMAND, IDCANCEL, 0)
If wParam = VK_F1 Then Return SendMessageW(hWnd, WM_COMMAND, 1808, 0)
Case WM_COMMAND
Select Case LoWord(wParam)
Case IDOK '确定: 返回 文本框内容
wResult = GetPropW(hWnd, "_ResultValue")
If wResult Then SendDlgItemMessageW(hWnd, 2000, WM_GETTEXT, 260, Cast(lParam, wResult))
SendMessageW(hWnd, WM_CLOSE, 0, 0)
Case IDCANCEL '取消: 什么也不做就可以了
SendMessageW(hWnd, WM_CLOSE, 0, 0)
Case 1808 '帮助:
''ToDo :
End Select
End Select
Function = DefWindowProcW(hWnd, uMsg, wParam, lParam)
End Function
Function InputBoxW(hParent As hWnd = 0, Prompt As LPCWSTR, Title As LPCWSTR = 0, Default As LPCWSTR = 0, xPos As Long = 0, yPos As Long = 0, HelpFile As LPCWSTR = 0, Context As Integer = 0) As StringW
''InputBox函数返回值缓存区
Dim dwBuff As WString * 260
''如果没有指定父窗体,将把桌面作为父窗体
If hParent = NULL OrElse IsWindow(hParent) = 0 Then hParent = GetDesktopWindow()
''如果传入的是子窗体句柄,逆推得到该句柄的顶层父窗体
While (GetWindowLongPtrW(hParent, GWL_STYLE) And WS_CHILD) = WS_CHILD
hParent = GetParent(hParent)
Wend
''创建输入对话框(Popup弹出式窗体)
Dim HHIN As Hinstance = GetModuleHandleW(NULL)
Dim hInputBox As hWnd = CreateWindowExW( _
WS_EX_DLGMODALFRAME Or WS_EX_CONTROLPARENT, _ '对话框样式|允许TAB跳转
"#32770", IIf(Title = 0, @(App.EXEName), Title), _
WS_VISIBLE Or WS_CAPTION Or WS_POPUPWINDOW, _ '带标题栏的弹出窗口
0, 0, 365, 155, hParent, 0, HHIN, 0 _
)
If hInputBox Then
''禁止拥有者窗体
EnableWindow(hParent, False)
''把输入框数据的返回地址存入窗体属性
SetPropW(hInputBox, "_ResultValue", Cast(HANDLE, @dwBuff[0]))
''修改输入框样式
Dim HHMenu As HMENU = GetSystemMenu(hInputBox, False)
If HHMenu Then
RemoveMenu(HHMenu, SC_MAXIMIZE, MF_BYCOMMAND) '去掉系统菜单的最大化
RemoveMenu(HHMenu, SC_MINIMIZE, MF_BYCOMMAND) '去掉系统菜单的最小化
RemoveMenu(HHMenu, SC_SIZE, MF_BYCOMMAND) '去掉系统菜单的大小
RemoveMenu(HHMenu, SC_RESTORE, MF_BYCOMMAND) '去掉系统菜单的还原
End If
''创建输入框子控件(标签+按钮+按钮+按钮+文本框)
CreateWindowExW(0, "Static", NULL, WS_CHILD Or WS_VISIBLE, 5, 5, 275, 80, hInputBox, Cast(HMENU, 1000), HHIN, 0)
CreateWindowExW(0, "Button", NULL, WS_CHILD Or WS_VISIBLE Or BS_DEFPUSHBUTTON, 285, 5, 65, 25, hInputBox, Cast(HMENU, IDOK), HHIN, 0)
CreateWindowExW(0, "Button", NULL, WS_CHILD Or WS_VISIBLE, 285, 35, 65, 25, hInputBox, Cast(HMENU, IDCANCEL), HHIN, 0)
CreateWindowExW(0, "Button", NULL, WS_CHILD, 285, 65, 65, 25, hInputBox, Cast(HMENU, 1808), HHIN, 0) '帮助按钮
CreateWindowExW(WS_EX_CLIENTEDGE, "Edit", NULL, WS_BORDER Or WS_CHILD Or WS_VISIBLE Or ES_AUTOHSCROLL Or ES_AUTOVSCROLL, 5, 95, 350, 25, hInputBox, Cast(HMENU, 2000), HHIN, 0)
''设置统一的字体
Dim As HGDIOBJ objFont = GetStockObject(DEFAULT_GUI_FONT)
SendDlgItemMessageW(hInputBox, 1000, WM_SETFONT, Cast(wParam, objFont), 0)
SendDlgItemMessageW(hInputBox, 1808, WM_SETFONT, Cast(wParam, objFont), 0)
SendDlgItemMessageW(hInputBox, 2000, WM_SETFONT, Cast(wParam, objFont), 0)
SendDlgItemMessageW(hInputBox, IDOK, WM_SETFONT, Cast(wParam, objFont), 0)
SendDlgItemMessageW(hInputBox, IDCANCEL, WM_SETFONT, Cast(wParam, objFont), 0)
''设置子控件的文本
Dim HH32 As Hinstance = GetModuleHandleW("user32.dll") : dwBuff = "&"
If LoadStringW(HH32, 800, @dwBuff[1], 30) Then SendDlgItemMessageW(hInputBox, IDOK, WM_SETTEXT, 0, Cast(lParam, @dwBuff[0]))
If LoadStringW(HH32, 801, @dwBuff[1], 30) Then SendDlgItemMessageW(hInputBox, IDCANCEL, WM_SETTEXT, 0, Cast(lParam, @dwBuff[0]))
If LoadStringW(HH32, 808, @dwBuff[1], 30) Then SendDlgItemMessageW(hInputBox, 1808, WM_SETTEXT, 0, Cast(lParam, @dwBuff[0]))
dwBuff[0] = 0
If Prompt Then SendDlgItemMessageW(hInputBox, 1000, WM_SETTEXT, 0, Cast(lParam, Prompt))
If Default Then SendDlgItemMessageW(hInputBox, 2000, WM_SETTEXT, 0, Cast(lParam, Default))
''显示输入框窗体
ShowWindow(hInputBox, SW_SHOWNORMAL)
UpdateWindow(hInputBox)
''计算输入框与拥有者父窗体的相对位置(根据xPos,yPos的指定值,如果未指定则父窗体居中)
Dim As Rect mRc, Rc : GetWindowRect(hParent, @mRc) : GetWindowRect(hInputBox, @Rc)
If xPos = 0 Then xPos = ((mRc.Right - mRc.Left) - (Rc.Right - Rc.Left)) / 2
If yPos = 0 Then yPos = ((mRc.bottom - mRc.top) - (Rc.bottom - Rc.top)) / 2
Rc.Left = mRc.Left + xPos : Rc.top = mRc.top + yPos
MoveWindow(hInputBox, Rc.Left, Rc.top, Rc.Right, Rc.bottom, True)
''子类化输入框,并进入内部的消息循环,因为父窗体已经禁止了
SetWindowLongPtrW(hInputBox, GWL_WNDPROC, Cast(LONG_PTR, @InputBoxWndProcW))
Dim uMsg As MSG
While GetMessageW(@uMsg, NULL, 0, 0)
TranslateMessage(@uMsg)
DispatchMessageW(@uMsg)
Wend
''输入框关闭了,恢复父窗体
EnableWindow(hParent, CTRUE)
SetFocus(hParent)
End If
Function = dwBuff
End Function |
|