PDA

View Full Version : Tặng các bạn InputBox, MsgBox cho phép tô màu nền và màu chữ - Nhân dịp tôi đổi nick



Nguyễn Duy Tuân
12-07-10, 05:14 PM
Nhân việc bạn thuyyeu99 nhờ tại đề tài Có cách nào tô màu nền và màu chữ cho Msgbox không (http://www.giaiphapexcel.com/forum/showthread.php?38011-C%C3%B3-c%C3%A1ch-n%C3%A0o-t%C3%B4-m%C3%A0u-n%E1%BB%81n-v%C3%A0-m%C3%A0u-ch%E1%BB%AF-cho-Msgbox-kh%C3%B4ng/page3)

Cũng là dịp tôi đổi nick mới trong GPE. Nhân sự kiện này viết tặng các bạn hai hàm InputBox và MsgBox cho phép to màu chữ và màu nền.

Mã nguồn được viết theo phương pháp lập trình Windows API (chỉ có cách này thôi), sử dụng kỹ thuật thuật hook của sổ, cấy vào nó một thủ tục "MsgBoxProc" để xử lý các thông điệp khi Windows vẽ cửa sổ InputBox và MsgBox.

Hai hàm InputBoxClr và MsgBoxClr được viết để gọi lệnh hook của sổ và gọi hàm gốc trong VBA là InputBox và MsgBox. Các đối số sử dụng tương tự nhau, chỉ thêm hai đối số bổ sung là BackColor và ForeColor để tô màu nền và màu chữ.


http://bluesofts.net/Products/BSAC/Help/Pics/MsgBoxTimer.jpg
http://bluesofts.net/Products/BSAC/Help/Pics/InputBoxPass.jpg



Function MsgBoxClr(ByVal Prompt As String, _
Optional ByVal Buttons As VbMsgBoxStyle = vbOKOnly, _
Optional ByVal Title As Variant, _
Optional HelpFile As Variant, _
Optional ByVal Context As Variant, _
Optional ByVal BackColor As Long = -1, _
Optional ByVal ForeColor As Long = -1) As VbMsgBoxResult
Dim inst&
inst = GetWindowLong(GetActiveWindow, GWL_HINSTANCE)
With MSG
.BackColor = BackColor
.ForeColor = ForeColor
'This is where you need to Hook the MsgBox
.HOOK = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookMsgBox, inst, GetCurrentThreadId)
MsgBoxClr = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
'Remove the Hook
Call UnhookWindowsHookEx(.HOOK)
.PrevProc = 0
End With
End Function
'-------------------------------------------------------------------------------------------------------
Function InputBoxClr(ByVal Prompt As String, _
Optional ByVal Title As String = vbNullString, _
Optional ByVal Default As Variant, _
Optional ByVal XPos As Variant, _
Optional ByVal YPos As Variant, _
Optional HelpFile As Variant, _
Optional ByVal Context As Variant, _
Optional ByVal BackColor As Long = -1, _
Optional ByVal ForeColor As Long = -1) As String
Dim inst&
inst = GetWindowLong(GetActiveWindow, GWL_HINSTANCE)
With MSG
.BackColor = BackColor
.ForeColor = ForeColor
'This is where you need to Hook the InputBox
.HOOK = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookMsgBox, inst, GetCurrentThreadId)
InputBoxClr = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
'Remove the Hook
Call UnhookWindowsHookEx(.HOOK)
.PrevProc = 0
End With
End Function
'-------------------------------------------------------------------------------------------------------
Private Function MsgBoxProc(ByVal hwnd As Long, ByVal uMSG As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tLB As LOGBRUSH
Select Case uMSG
Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC
If MSG.ForeColor <> -1 Then Call SetTextColor(wParam, MSG.ForeColor)
If MSG.BackColor <> -1 Then Call SetBkColor(wParam, MSG.BackColor)
'Create a Solid Brush using that Color
If MSG.BackColor <> -1 Then
tLB.lbColor = MSG.BackColor
'Return the Handle to the Brush to Paint the MsgBox
MsgBoxProc = CreateBrushIndirect(tLB)
Exit Function
End If
Case WM_DESTROY
'Remove the MsgBox Subclassing
Call SetWindowLong(hwnd, GWL_WNDPROC, MSG.PrevProc)
End Select
MsgBoxProc = CallWindowProc(MSG.PrevProc, hwnd, uMSG, wParam, ByVal lParam)
End Function


Toàn bộ mã nguồn được gửi trong file đính kèm.

thuyyeu99
14-07-10, 08:25 AM
Cho em hỏi them vấn đề này 1 chút ? làm cách nào mà mình disable được một nút command trên msgbox hay inputbox, hay nhấn vào nó không thực thi lệnh giống như nút trợ giúp của anh vậy

thanhlanh
14-07-10, 08:35 AM
Các bạn cho hỏi câu lệnh trả về path (địa chỉ) của file hiện hành (ghi vào một cell, hiển thị thông báo)

thuyyeu99
14-07-10, 09:06 AM
Các bạn cho hỏi câu lệnh trả về path (địa chỉ) của file hiện hành (ghi vào một cell, hiển thị thông báo)
Bạn hỏi sai toppic roi nhé
MsgBox Application.ThisWorkbook.Path

thanhlanh
14-07-10, 09:19 AM
Bạn hỏi sai toppic roi nhé
MsgBox Application.ThisWorkbook.Path
Cảm ơn Bạn, đừng phạt người chưa biết.
Nhưng câu này có tương đương không: MsgBox (CurDir)

thuyyeu99
30-07-10, 09:21 AM
Nhờ sự giúp đỡ của anh Nguyễn Duy Tuân em lam được Msgbox va inputbox thời gian.(Khi Pass không nhập thì không cho nhấn nút chấp nhận, thay đổi tên nút, nút nào được chọn khi hết thời gian thì tô đậm và muốn cho hiện giây hay không hiện, to đậm chữ trong prom )

50009

Tiger62
31-07-10, 12:04 AM
Chúc mừng Thầy Tuân đổi nick kèm quà tặng. Mong Thầy có nhiều thành công mới.