- Tham gia
- 13/6/06
- Bài viết
- 4,772
- Được thích
- 10,284
- Giới tính
- Nam
- Nghề nghiệp
- Giáo viên, CEO tại Bluesofts
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
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ữ.
Toàn bộ mã nguồn được gửi trong file đính kèm.
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ữ.
Mã:
Function [B]MsgBoxClr[/B](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
[COLOR="SeaGreen"]'This is where you need to Hook the MsgBox[/COLOR]
.HOOK = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookMsgBox, inst, GetCurrentThreadId)
MsgBoxClr = MsgBox(Prompt, Buttons, Title, HelpFile, Context)
[COLOR="SeaGreen"] 'Remove the Hook[/COLOR]
Call UnhookWindowsHookEx(.HOOK)
.PrevProc = 0
End With
End Function
[COLOR="SeaGreen"]'-------------------------------------------------------------------------------------------------------[/COLOR]
Function [B]InputBoxClr[/B](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
[COLOR="SeaGreen"]'This is where you need to Hook the InputBox[/COLOR]
.HOOK = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookMsgBox, inst, GetCurrentThreadId)
InputBoxClr = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
[COLOR="SeaGreen"] 'Remove the Hook[/COLOR]
Call UnhookWindowsHookEx(.HOOK)
.PrevProc = 0
End With
End Function
[COLOR="SeaGreen"]'-------------------------------------------------------------------------------------------------------[/COLOR]
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)
[COLOR="SeaGreen"]'Create a Solid Brush using that Color[/COLOR]
If MSG.BackColor <> -1 Then
tLB.lbColor = MSG.BackColor
[COLOR="SeaGreen"]'Return the Handle to the Brush to Paint the MsgBox[/COLOR]
MsgBoxProc = CreateBrushIndirect(tLB)
Exit Function
End If
Case WM_DESTROY
[COLOR="SeaGreen"]'Remove the MsgBox Subclassing[/COLOR]
Call SetWindowLong(hwnd, GWL_WNDPROC, MSG.PrevProc)
End Select
MsgBoxProc = CallWindowProc(MSG.PrevProc, hwnd, uMSG, wParam, ByVal lParam)
End FunctionToàn bộ mã nguồn được gửi trong file đính kèm.
