Option Explicit
Private Type LOGBRUSH lbStyle As Long lbColor As Long lbHatch As Long End Type Private 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 Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long) Private 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 Private Declare Function CallNextHookEx Lib "user32" (ByVal hHook As Long, ByVal nCode As Long, ByVal wParam As Long, lParam As Any) As Long Private Declare Function UnhookWindowsHookEx Lib "user32" (ByVal hHook As Long) As Long Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long Private 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 Private Declare Function GetClassName Lib "user32" Alias "GetClassNameA" (ByVal hwnd As Long, ByVal lpClassName As String, ByVal nMaxCount As Long) As Long Private Declare Function SetBkColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private Declare Function SetTextColor Lib "gdi32" (ByVal hdc As Long, ByVal crColor As Long) As Long Private 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 Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long ' System Color Constants Private Const COLOR_BTNFACE = 15 Private Const COLOR_BTNTEXT = 18 ' SetWindowPos Constants Private Const SWP_FRAMECHANGED = &H20 Private Const SWP_NOSIZE = &H1 Private Const SWP_NOZORDER = &H4 Private Const WH_CALLWNDPROC = 4 Private Const GWL_WNDPROC = (-4) ' Windows Messages Private Const WM_GETFONT = &H31 Private Const WM_CREATE = &H1 Private Const WM_CTLCOLORBTN = &H135 Private Const WM_CTLCOLORDLG = &H136 Private Const WM_CTLCOLORSTATIC = &H138 Private Const WM_CTLCOLOREDIT = &H133 Private Const WM_DESTROY = &H2 Private Const WM_SHOWWINDOW = &H18 Private Const WM_COMMAND = &H111 Private Const BN_CLICKED = 0 Private Const IDOK = 1 Private Const EM_SETPASSWORDCHAR = &HCC ' InputboxEx Variables Private INPUTBOX_HOOK As Long Private INPUTBOX_HWND As Long Private INPUTBOX_PASSCHAR As String Private INPUTBOX_BACKCOLOR As Long Private INPUTBOX_FORECOLOR As Long Private INPUTBOX_FONT As String Private INPUTBOX_FONTSIZE As Integer Private INPUTBOX_SHOWING As Boolean Private INPUTBOX_CENTERV As Boolean Private INPUTBOX_CENTERH As Boolean Private INPUTBOX_OK As Boolean '_____________________________________________________________ Private Function InputBoxProc(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 Dim lNotify As Long Dim lID As Long Select Case Msg Case WM_COMMAND 'Check to see if the OK Button was Pressed.. lNotify = Val("&H" & Left$(Right$("00000000" & Hex$(wParam), 8), 4)) lID = Val("&H" & Right$(Right$("00000000" & Hex$(wParam), 8), 4)) If lNotify = BN_CLICKED Then INPUTBOX_OK = (lID = IDOK) End If Case WM_SHOWWINDOW 'Reposition Inputbox if Neccessary Call GetWindowRect(hwnd, tRECT) If INPUTBOX_CENTERH Then tRECT.Left = ((Screen.Width / Screen.TwipsPerPixelX) - (tRECT.Right - tRECT.Left)) / 2 If INPUTBOX_CENTERV 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, WM_CTLCOLOREDIT 'set the Colors If Msg = WM_CTLCOLOREDIT Then If Len(INPUTBOX_PASSCHAR) Then Call SendMessage(lParam, EM_SETPASSWORDCHAR, Asc(INPUTBOX_PASSCHAR), ByVal 0&) End If Else 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) 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 Inputbox InputBoxProc = CreateBrushIndirect(tLB) Exit Function End If Case WM_DESTROY 'Remove the Inputbox Subclassing Call SetWindowLong(hwnd, GWL_WNDPROC, INPUTBOX_HWND) End Select InputBoxProc = CallWindowProc(INPUTBOX_HWND, hwnd, Msg, wParam, ByVal lParam) End Function '_____________________________________________________________ Private 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 INPUTBOX_SHOWING Then 'Subclass the Inputbox as it's created INPUTBOX_HWND = SetWindowLong(tCWP.hwnd, GWL_WNDPROC, AddressOf InputBoxProc) End If End If End If HookWindow = CallNextHookEx(INPUTBOX_HOOK, 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, optional ByVal PasswordChar As String, optional ByVal CancelError As Boolean = False) 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) INPUTBOX_CENTERH = (XPos = -1) INPUTBOX_CENTERV = (YPos = -1) INPUTBOX_PASSCHAR = PasswordChar '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 INPUTBOX_SHOWING = True 'Monitor All Messages to this Thread. INPUTBOX_HOOK = SetWindowsHookEx(WH_CALLWNDPROC, AddressOf HookWindow, App.hInstance, App.ThreadID) InputBoxEx = InputBox(Prompt, Title, Default, XPos, YPos, HelpFile, Context) INPUTBOX_SHOWING = False 'Remove the Hook Call UnhookWindowsHookEx(INPUTBOX_HOOK) If Not INPUTBOX_OK And CancelError Then Err.Raise vbObjectError + 1, , "User Pressed " & Chr(34) & "Cancel" & Chr(34) End Function '* Allows the inbuilt InputBox to be Customized in '* the following ways: '* '* Back/ForeColor '* Font/Fontsize '* Dialog Centering '* Password Character Masking '* Can Raise a Trappable error when the Dialog is Cancelled '* '* Usage: '* '* Result = InputboxEx( _ '* Message,[Title],[Default],[Default],[XPos],[YPos], _ '* [HelpFile],[Context],[ForeColor],[BackColor], _ '* [FontName],[FontSize],[PasswordChar],[CancelError]) '* '* This code is Freeware, but if you use it in whole '* or part, I would appreciate some credit for my work. '* '******************************************************* |