unit JB_Hookedit;
interface
uses
Messages, SysUtils, ClipBrd, Classes, StdCtrls, ExtCtrls;
type
THookEvent =
procedure(nCode: Integer; wParam, lParam: Integer)
of object;
TJB_HookEdit =
class(TComponent)
private
FHookEdit : TCustomEdit;
FActive : Boolean;
FOnGetMsg : THookEvent;
FOnWndProc : THookEvent;
FOnWndProcRet : THookEvent;
function GetSecretChar: Char;
function GetSecretTextMaxLength: Integer;
procedure SetHookEdit(
const Value: TCustomEdit);
procedure SetSecretChar(
const Value: Char);
procedure SetSecretTextMaxLength(
const Value: Integer);
procedure SetActive(
const Value: Boolean);
procedure SetOnGetMsg(
const Value: THookEvent);
procedure SetOnWndProc(
const Value: THookEvent);
procedure SetOnWndProcRet(
const Value: THookEvent);
public
constructor Create(AOwner: TComponent);
override;
destructor Destroy;
override;
function SecretText:
string;
overload;
function SecretText(AEdit: TCustomEdit):
string;
overload;
procedure Clear;
procedure RegisterHooks;
property Active: Boolean
read FActive
write SetActive;
published
property HookEdit: TCustomEdit
read FHookEdit
write SetHookEdit;
property SecretChar: Char
read GetSecretChar
write SetSecretChar;
property SecretTextMaxLength: Integer
read GetSecretTextMaxLength
write SetSecretTextMaxLength;
property OnGetMsg: THookEvent
read FOnGetMsg
write SetOnGetMsg;
property OnWndProc: THookEvent
read FOnWndProc
write SetOnWndProc;
property OnWndProcRet: THookEvent
read FOnWndProcRet
write SetOnWndProcRet;
end;
procedure Register;
implementation
uses
Windows;
var
FClipBoard : TClipBoard =
nil;
FSecretLines : TStringList =
nil;
FKeyState : TKeyBoardState;
FCTRLDown : Boolean = false;
FInitCBText :
string;
// CB = ClipBoard
FHookWnd : HWND = 0;
FHook_GetMsg : HHOOK = 0;
FHook_WndProc : HHOOK = 0;
FHook_WndProcRet : HHOOK = 0;
FSecretLineID : Integer = 0;
FSecretChar : Char = '
*';
FSecretTextMaxLength : Integer = 0;
FMX_HookEdit : TJB_HookEdit =
nil;
procedure RegHooks;
forward;
procedure UnregHooks;
forward;
function ProcessStr(
var S:
string; MaxLength: Integer): Boolean;
forward;
procedure CleanupString(
var S:
string);
forward;
procedure GetStartEndSel(
var StartSel, EndSel: Integer);
forward;
{ Create }
constructor TJB_HookEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
//
if (FMX_HookEdit <>
nil)
then
begin
if (FMX_HookEdit.Owner <>
nil)
then
FMX_HookEdit.Owner.RemoveComponent(FMX_HookEdit);
FMX_HookEdit.Free;
end;
//
// FPreventPaste:= true;
//
FMX_HookEdit := Self;
//
FActive := false;
FHookEdit :=
nil;
FSecretLineID := -1;
FSecretChar := '
*';
FSecretTextMaxLength := 0;
//
if (FSecretLines =
nil)
then FSecretLines := TStringList.Create;
if (FClipBoard =
nil)
then FClipBoard := TClipBoard.Create;
end;
{
Password_Edit.Font.Charset := 2;
Password_Edit.PasswordChar := 'l';
}
{ Destroy }
destructor TJB_HookEdit.Destroy;
begin
try
UnregHooks;
if (FClipBoard <>
nil)
then
begin
FClipBoard.Free;
FClipBoard:=
nil
end;
if (FSecretLines <>
nil)
then
begin
FSecretLines.Free;
FSecretLines :=
nil
end;
//
FMX_HookEdit :=
nil;
finally
inherited;
end;
end;
{ RegisterHooks }
procedure TJB_HookEdit.RegisterHooks;
begin
RegHooks;
end;
{ Clear }
procedure TJB_HookEdit.Clear;
var
I : Integer;
begin
FInitCBText := '
';
if (FSecretLines <>
nil)
then
for I := 0
to FSecretLines.Count - 1
do
FSecretLines[I] := '
';
end;
{ SecretText - I }
function TJB_HookEdit.SecretText:
string;
begin
Result := SecretText(FHookEdit);
end;
function TJB_HookEdit.SecretText(AEdit: TCustomEdit):
string;
var
I, IMax : Integer;
VEditFound : Boolean;
begin
Result := '
';
if (
not (AEdit
is TCustomEdit))
or (FSecretLines =
nil)
then
Exit;
//
if (FSecretLines.Count > 0)
then
begin
I := -1;
IMax := FSecretLines.Count -1 ;
repeat
Inc(I);
VEditFound := (TCustomEdit(FSecretLines.Objects[I]) = AEdit);
if VEditFound
then
Result := FSecretLines[I];
until
(I = IMax)
or VEditFound;
end;
end;
{ GetSecretChar }
function TJB_HookEdit.GetSecretChar: Char;
begin
Result := FSecretChar;
end;
{ GetSecretTextMaxLength }
function TJB_HookEdit.GetSecretTextMaxLength: Integer;
begin
Result := FSecretTextMaxLength;
end;
{ SetHookEdit}
procedure TJB_HookEdit.SetHookEdit(
const Value: TCustomEdit);
var
I, IMax : Integer;
VEditFound : Boolean;
VText :
string;
begin
if (FHookEdit <> Value)
then
begin
FHookEdit := Value;
FHookWnd := 0;
FSecretLineID := -1;
//
if (FHookEdit <>
nil)
then
begin
FHookWnd := FHookEdit.Handle;
VEditFound := false;
//
if (FSecretLines <>
nil)
then
begin
if (FSecretLines.Count > 0)
then
begin
I := -1;
IMax := FSecretLines.Count - 1;
repeat
Inc(I);
VEditFound := TCustomEdit(FSecretLines.Objects[I]) = FHookEdit;
until
(I = IMax)
or VEditFound;
if VEditFound
then
FSecretLineID := I;
end;
//
if (
not VEditFound)
then
begin
FSecretLineID := FSecretLines.Count;
VText := FHookEdit.Text;
FSecretLines.AddObject(VText, FHookEdit);
//
for I := 1
to Length(VText)
do
VText[I] := SecretChar;
FHookEdit.Text := VText;
end;
end;
end;
end;
end;
{ SetSecretChar }
procedure TJB_HookEdit.SetSecretChar(
const Value: Char);
begin
FSecretChar := Value;
end;
{ SetSecretTextMaxLength }
procedure TJB_HookEdit.SetSecretTextMaxLength(
const Value: Integer);
begin
FSecretTextMaxLength := Value;
end;
{ SetActive }
procedure TJB_HookEdit.SetActive(
const Value: Boolean);
begin
FActive := Value
and (
not (csDesigning
in ComponentState));
if FActive
then RegHooks
else UnregHooks;
end;
{ SetSecretLine }
procedure SetSecretLine(ALineID: Integer;
const ALine:
string);
var
VLine :
string;
begin
if (FSecretLines <>
nil)
and (ALineID >= 0)
and (ALineID < FSecretLines.Count)
then
begin
VLine := ALine;
CleanupString(VLine);
FSecretLines[ALineID] := VLine;
end;
end;
{ ProcessStr }
function ProcessStr(
var S:
string; MaxLength: Integer): Boolean;
var
VLen : Integer;
begin
VLen := 0;
if (S <> '
')
and (MaxLength > 0)
then
begin
CleanupString(S);
VLen := Length(S) - MaxLength;
if (VLen > 0)
then
Delete(S, MaxLength + 1, VLen);
end;
Result := (VLen <= 0);
end;
{ CleanupString }
procedure CleanupString(
var S:
string);
var
I, IMax : Integer;
VChar : Char;
begin
IMax := Length(S);
for I := IMax
downto 1
do
begin
if (S[I] = #$0A)
then
begin
if (I = 1)
then
VChar := #0
else
VChar := S[I - 1];
if (VChar <> #$0D)
then
Delete(S, I, 1);
end;
//
if (S[I] = #$0D)
then
begin
if (I = IMax)
then
VChar := #0
else
VChar := S[I + 1];
if (VChar <> #$0A)
then
Delete(S, I, 1);
end;
end;
end;
{ GetStartEndSel }
procedure GetStartEndSel(
var StartSel, EndSel: Integer);
var
VResult : Integer;
begin
if IsWindow(FHookWnd)
then
VResult := SendMessage(FHookWnd, EM_GETSEL, 0, 0)
else
VResult := -1;
//
if (VResult <> -1)
then
begin
StartSel := (VResult
and $0000FFFF);
EndSel := (VResult
and $FFFF0000)
shr 8;
// original 16
end
else
begin
StartSel := 0;
EndSel := 0;
end;
end;
{ GetMsgProc }
function GetMsgProc(nCode: Integer; wParam, lParam: Integer): LResult;
stdcall;
{ process messages:
WM_KEYUP
VK_CONTROL
WM_KEYDOWN
VK_CONTROL
VK_BACK
VK_DELETE
VK_ENTER
WM_CHAR
}
const
VChar = $38;
var
VMsg : PMsg;
VMess : Cardinal;
VWndValid : Boolean;
VStartSel : Integer;
VEndSel : Integer;
VKeyState : TKeyBoardState;
VVirtKey : Integer;
VScanCode : Integer;
VCharCode :
array[0..3]
of Char;
VRetVal : Smallint;
VKBLayout : HKL;
S :
string;
begin
Result := 0;
//
if (nCode < 0)
then
Result := CallNextHookEx(FHook_GetMsg, nCode, wParam, lParam)
else
if (nCode = HC_ACTION)
then
begin
VMsg := PMsg(Pointer(lParam));
VWndValid := IsWindow(FHookWnd)
and (VMsg.hwnd = FHookWnd);
if VWndValid
and (FSecretLines <>
nil)
and (FSecretLineID >= 0)
and (FSecretLineID < FSecretLines.Count)
then begin
S := FSecretLines[FSecretLineID];
VMess := VMsg.
message;
case VMess
of
// WM_KEYUP
WM_KEYUP :
begin
VVirtKey := VMsg.wParam;
case VVirtKey
of
// VK_CONTROL
VK_CONTROL :
begin
FCTRLDown := false;
end;
end;
end;
// WM_KEYDOWN
WM_KEYDOWN :
begin
GetKeyBoardState(FKeyState);
//
VVirtKey := VMsg.wParam;
case VVirtKey
of
// VK_CONTROL
VK_CONTROL :
begin
FCTRLDown := true;
end;
// VK_BACK
VK_BACK :
begin
GetStartEndSel(VStartSel, VEndSel);
Delete(S, VStartSel, VEndSel - VStartSel + 1);
end;
// VK_DELETE
VK_DELETE :
begin
GetStartEndSel(VStartSel, VEndSel);
if (VEndSel = VStartSel)
then
Delete(S, VStartSel + 1, VEndSel - VStartSel + 1)
else
Delete(S, VStartSel + 1, VEndSel - VStartSel);
end;
// VK_RETURN
VK_RETURN :
begin
GetStartEndSel(VStartSel, VEndSel);
Delete(S, VStartSel + 1, VEndSel - VStartSel);
end;
// VK_...
else
begin
if not FCTRLDown
then
begin
GetKeyBoardState(VKeyState);
VScanCode := VMsg.lParam
and $FF0000;
ZeroMemory(@VCharCode, SizeOf(VCharCode));
VKBLayout := GetKeyBoardLayout(GetCurrentThreadID);
VRetVal := ToASCIIEx(VVirtKey, VScanCode, VKeyState, @VCharCode, 0, VKBLayout);
//
if (VRetVal <> 0)
then
begin
GetStartEndSel(VStartSel, VEndSel);
Delete(S, VStartSel + 1, VEndSel - VStartSel);
Insert(VCharCode, S, VStartSel + 1);
//
if ProcessStr(S, FSecretTextMaxLength)
then
begin
VKeyState[VK_SHIFT] := 0;
SetKeyBoardState(VKeyState);
VMsg.wParam := VChar;
end
else
VMsg.wParam := 0
end;
end;
end;
end;
end;
// WM_CHAR
WM_CHAR :
begin
case VMsg.wParam
of
$09 : S := S + #09;
$0D : S := S + #$0D#$0A;
VChar : VMsg.wParam := Ord(FSecretChar);
end;
//
SetKeyBoardState(FKeyState);
end;
end;
//
SetSecretLine(FSecretLineID, S);
end;
end;
//
if (FMX_HookEdit <>
nil)
and Assigned(FMX_HookEdit.FOnGetMsg)
then
FMX_HookEdit.FOnGetMsg(nCode, wParam, lParam);
end;
{ CallWndProc }
function CallWndProc(nCode: Integer; wParam, lParam: Integer): LResult;
stdcall;
{ process messages:
WM_PASTE
WM_CLEAR
WM_CUT
}
var
VStruct : PCWPSTRUCT;
VMess : Cardinal;
VWndValid : Boolean;
VStartSel : Integer;
VEndSel : Integer;
VCBText :
string;
VCBBuffSize : Integer;
S :
string;
begin
Result := 0;
//
if (nCode < 0)
then
Result := CallNextHookEx(FHook_GetMsg, nCode, wParam, lParam)
else
if (nCode = HC_ACTION)
then
begin
VStruct := PCWPSTRUCT(Pointer(lParam));
VWndValid := IsWindow(FHookWnd)
and (VStruct.hwnd = FHookWnd);
if VWndValid
and (FClipBoard <>
nil)
and (FSecretLines <>
nil)
and (FSecretLineID >= 0)
and (FSecretLineID < FSecretLines.Count)
then begin
S := FSecretLines[FSecretLineID];
VMess := VStruct.
message;
//
case VMess
of
// WM_PASTE
WM_PASTE :
begin
FInitCBText := FClipBoard.AsText;
VCBBuffSize := Length(FInitCBText);
SetLength(VCBText, VCBBuffSize); FillMemory(PChar(VCBText), VCBBuffSize, Ord(FSecretChar));
FClipBoard.SetTextBuf(PChar(VCBText));
//
GetStartEndSel(VStartSel, VEndSel);
Delete(S, VStartSel + 1, VEndSel - VStartSel);
Insert(FInitCBText, S, VStartSel + 1);
//
ProcessStr(S, FSecretTextMaxLength);
end;
// WM_CLEAR, WM_CUT
WM_CLEAR, WM_CUT :
begin
GetStartEndSel(VStartSel, VEndSel);
if (VEndSel = VStartSel)
then
Delete(S, VStartSel + 1, VEndSel - VStartSel + 1)
else
Delete(S, VStartSel + 1, VEndSel - VStartSel);
end;
end;
//
SetSecretLine(FSecretLineID, S);
end;
end;
//
if (FMX_HookEdit <>
nil)
and Assigned(FMX_HookEdit.FOnWndProc)
then
FMX_HookEdit.FOnWndProc(nCode, wParam, lParam);
end;
{ CallWndProcRet }
function CallWndProcRet(nCode: Integer; wParam, lParam: Integer): LResult;
stdcall;
{ process messages:
WM_PASTE
}
var
VStruct : PCWPRETSTRUCT;
VMess : Cardinal;
VWndValid : Boolean;
begin
Result := 0;
if (nCode < 0)
then
Result := CallNextHookEx(FHook_GetMsg, nCode, wParam, lParam)
else
if (nCode = HC_ACTION)
then
begin
VStruct := PCWPRETSTRUCT(Pointer(lParam));
VWndValid := IsWindow(FHookWnd)
and (VStruct.hwnd = FHookWnd);
if VWndValid
and (FClipBoard <>
nil)
then
begin
VMess := VStruct.
message;
//
case VMess
of
// WM_PASTE
WM_PASTE :
begin
FClipBoard.SetTextBuf(PChar(FInitCBText));
end;
end;
end;
end;
//
if (FMX_HookEdit <>
nil)
and Assigned(FMX_HookEdit.FOnWndProcRet)
then
FMX_HookEdit.FOnWndProcRet(nCode, wParam, lParam);
end;
{ RegHook_GetMsg }
procedure RegHook_GetMsg;
begin
if (FHook_GetMsg = 0)
then
FHook_GetMsg := SetWindowsHookEx(WH_GETMESSAGE, @GetMsgProc, HInstance, GetCurrentThreadID)
else
begin
if UnhookWindowsHookEx(FHook_GetMsg)
then
FHook_GetMsg := SetWindowsHookEx(WH_GETMESSAGE, @GetMsgProc, HInstance, GetCurrentThreadID)
end;
end;
{ UnregHook_GetMsg }
procedure UnregHook_GetMsg;
begin
if (FHook_GetMsg <> 0)
then
if UnhookWindowsHookEx(FHook_GetMsg)
then
FHook_GetMsg := 0;
end;
{ RegHook_WndProc }
procedure RegHook_WndProc;
begin
if (FHook_WndProc = 0)
then
FHook_WndProc := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndProc, HInstance, GetCurrentThreadID)
else
begin
if UnhookWindowsHookEx(FHook_WndProc)
then
FHook_WndProc := SetWindowsHookEx(WH_CALLWNDPROC, @CallWndProc, HInstance, GetCurrentThreadID)
end;
end;
{ UnregHook_WndProc }
procedure UnregHook_WndProc;
begin
if (FHook_WndProc <> 0)
then
if UnhookWindowsHookEx(FHook_WndProc)
then
FHook_WndProc := 0;
end;
{ RegHook_WndProcRet }
procedure RegHook_WndProcRet;
begin
if (FHook_WndProcRet = 0)
then
FHook_WndProcRet := SetWindowsHookEx(WH_CALLWNDPROCRET, @CallWndProcRet, HInstance, GetCurrentThreadID)
else
begin
if UnhookWindowsHookEx(FHook_WndProcRet)
then
FHook_WndProcRet := SetWindowsHookEx(WH_CALLWNDPROCRET, @CallWndProcRet, HInstance, GetCurrentThreadID)
end;
end;
{ UnregHook_WndProcRet }
procedure UnregHook_WndProcRet;
begin
if (FHook_WndProcRet <> 0)
then
if UnhookWindowsHookEx(FHook_WndProcRet)
then
FHook_WndProcRet := 0;
end;
{ RegHooks}
procedure RegHooks;
begin
RegHook_WndProcRet;
RegHook_WndProc;
RegHook_GetMsg;
end;
{ UnregHooks }
procedure UnregHooks;
begin
UnregHook_GetMsg;
UnregHook_WndProc;
UnregHook_WndProcRet;
end;
{ SetOnGetMsg }
procedure TJB_HookEdit.SetOnGetMsg(
const Value: THookEvent);
begin
FOnGetMsg := Value;
end;
{ SetOnWndProc }
procedure TJB_HookEdit.SetOnWndProc(
const Value: THookEvent);
begin
FOnWndProc := Value;
end;
{ SetOnWndProcRet }
procedure TJB_HookEdit.SetOnWndProcRet(
const Value: THookEvent);
begin
FOnWndProcRet := Value;
end;
procedure Register;
begin
RegisterComponents('
JB Security', [TJB_HookEdit]);
end;
end.