ChgFontInputMsgBox




'* Allows the Back/Fore Color and Font Name/Size of

'* an InputBox to be Customized.

Option Explicit
Public Type LOGBRUSH
lbStyle As Long
lbColor As Long
lbHatch As Long
End Type
Public Type CWPSTRUCT
lParam As Long
wParam As Long
message As Long
hwnd As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function SetWindowsHookEx Lib "user32" Alias "SetWindowsHookExA" (ByVal idHook As Long, ByVal lpfn As Long, ByVal hmod As Long, ByVal dwThreadId As Long) As Long
Public Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long
Public Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long
Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Public Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long
Public Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long
Public Declare Function CreateBrushIndirect Lib "gdi32" (lpLogBrush As LOGBRUSH) As Long
Private Declare Function CreateFont Lib "gdi32" Alias "CreateFontA" (ByVal H As Long, ByVal W As Long, ByVal E As Long, ByVal O As Long, ByVal W As Long, ByVal I As Long, ByVal u As Long, ByVal S As Long, ByVal C As Long, ByVal OP As Long, ByVal CP As Long, ByVal Q As Long, ByVal PAF As Long, ByVal F As String) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function SetWindowPos Lib "user32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal x As Long, ByVal y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long) As Long
Private Declare Function GetWindowRect Lib "user32" (ByVal hwnd As Long, lpRect As RECT) As Long
Private Declare Function GetSysColor Lib "user32" (ByVal nIndex As Long) As Long
Private Const COLOR_BTNFACE = 15
Private Const COLOR_BTNTEXT = 18
Private Const WM_GETFONT = &H31
Private Const SWP_FRAMECHANGED = &H20
Private Const SWP_NOSIZE = &H1
Private Const SWP_NOZORDER = &H4
Public Const WH_CALLWNDPROC = 4
Private Const GWL_WNDPROC = (-4)
Private Const WM_CREATE = &H1
Private Const WM_CTLCOLORBTN = &H135
Private Const WM_CTLCOLORDLG = &H136
Private Const WM_CTLCOLORSTATIC = &H138
Private Const WM_DESTROY = &H2
Private Const WM_SHOWWINDOW = &H18
Public lHook As Long
Private lPrevWnd As Long
Private INPUTBOX_BACKCOLOR As Long
Private INPUTBOX_FORECOLOR As Long
Private INPUTBOX_FONT As String
Private INPUTBOX_FONTSIZE As Integer
Private bShowingIB As Boolean
Private bCentVert As Boolean
Private bCentHorz As Boolean
Public Function SubMsgBox(ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tLB As LOGBRUSH
Dim lFont As Long
Dim tRECT As RECT

Select Case Msg
Case WM_SHOWWINDOW
'Reposition Inputbox if Neccessary

Call GetWindowRect(hwnd, tRECT)
If bCentHorz Then tRECT.Left = ((Screen.Width / Screen.TwipsPerPixelX) - (tRECT.Right - tRECT.Left)) / 2
If bCentVert Then tRECT.Top = ((Screen.Height / Screen.TwipsPerPixelY) - (tRECT.Bottom - tRECT.Top)) / 2
Call SetWindowPos(hwnd, 0, tRECT.Left, tRECT.Top, 0, 0, SWP_NOSIZE Or SWP_NOZORDER Or SWP_FRAMECHANGED)

Case WM_CTLCOLORDLG, WM_CTLCOLORSTATIC, WM_CTLCOLORBTN
'set the Colors

Call SetTextColor(wParam, INPUTBOX_FORECOLOR)
Call SetBkColor(wParam, INPUTBOX_BACKCOLOR)
If Msg = WM_CTLCOLORSTATIC Then
'set the Font

lFont = CreateFont(-((INPUTBOX_FONTSIZE / 72) * 96), 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, INPUTBOX_FONT)<
' lFont = CreateFont(INPUTBOX_FONTSIZE, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, INPUTBOX_FONT)

Call SelectObject(wParam, lFont)
End If
'Create a Solid Brush using that Color

tLB.lbColor = INPUTBOX_BACKCOLOR
'Return the Handle to the Brush to Paint the Messagebox

SubMsgBox = CreateBrushIndirect(tLB)
Exit Function

Case WM_DESTROY
'Remove the Inputbox Subclassing

Call SetWindowLong(hwnd, GWL_WNDPROC, lPrevWnd)
End Select
SubMsgBox = CallWindowProc(lPrevWnd, hwnd, Msg, wParam, ByVal lParam)
End Function

Public Function HookWindow(ByVal nCode As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
Dim tCWP As CWPSTRUCT
Dim sClass As String
'This is where you need to Hook the Inputbox

CopyMemory tCWP, ByVal lParam, Len(tCWP)
If tCWP.message = WM_CREATE Then
sClass = Space(255)
sClass = Left(sClass, GetClassName(tCWP.hwnd, ByVal sClass, 255))
If sClass = "#32770" Then
If bShowingIB Then
'Subclass the Inputbox as it's created

lPrevWnd = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf SubMsgBox)
End If
End If
End If
HookWindow = CallNextHookEx(lHook, nCode, wParam, ByVal lParam)
End Function

Public Function InputBoxEx(ByVal Prompt As String, optional ByVal Title As String, optional ByVal Default As String, optional ByVal XPos As Single = -1, optional ByVal YPos As Single = -1, optional ByVal HelpFile As String, optional ByVal Context As Long, optional ByVal ForeColor As ColorConstants, optional ByVal BackColor As ColorConstants, optional ByVal FontName As String, optional ByVal FontSize As Long) As String
'set the Defaults

If Len(Title) = 0 Then Title = App.Title
INPUTBOX_FONT = "MS Sans Serif"
INPUTBOX_FONTSIZE = 8
INPUTBOX_FORECOLOR = GetSysColor(COLOR_BTNTEXT)
INPUTBOX_BACKCOLOR = GetSysColor(COLOR_BTNFACE)
bCentHorz = (XPos = -1)
bCentVert = (YPos = -1)
'set the Font and Colors

If Len(FontName) Then INPUTBOX_FONT = FontName
If FontSize > 0 Then INPUTBOX_FONTSIZE = FontSize
If ForeColor > 0 Then INPUTBOX_FORECOLOR = ForeColor
If BackColor > 0 Then INPUTBOX_BACKCOLOR = BackColor
'Show the Modified Inputbox

bShowingIB = True
InputBoxEx = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context)
bShowingIB = False
End Function

'

'In the Form..

'

Private Sub Command1_Click()
On Error GoTo CancelError
With CommonDialog1
.CancelError = True
.Flags = cdlCFScreenFonts
.ShowFont
'Use Modified InputBox with Selected Font and Size

Caption = InputBoxEx("This is a Modified Inputbox!!", , , , , , , , , .FontName, .FontSize)
End With
CancelError:
End Sub

Private Sub Form_Load()
'Monitor All Messages to this Thread.

lHook = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, App.hInstance, App.ThreadID)
End Sub

Private Sub Form_Unload(Cancel As Integer)
'Remove the Hook

Call UnhookWindowsHookEx(lHook)
End Sub

Here's some code I've been working on to Modify things like the
System Dialogs, this one offers an InputBoxEx function which has
additional parameters for BackColor, ForeColor, FontName and
FontSize.










( chgfontinputmsgbox.html )- by Paolo Puglisi - Modifica del 17/12/2023