(на основе неоконного компонента):
<{CODE_COLLAPSE_OFF}><{CODE_WRAP_OFF}>
unit HSHintEdit;
interface
uses Windows, Messages, SysUtils, Classes, Controls, Graphics, AppEvnts,
TypInfo;
type
EHSHintEditException = class(Exception);
THSHintEdit = class(TComponent)
private
FHintWnd: THintWindow;
FCanvas: TCanvas;
FAppEvnts: TApplicationEvents;
FActive: Boolean;
FAlwaysShowHint: Boolean;
FBufferArray: Array of Char;
procedure AdjustHint(Wnd: HWND; Point: TPoint);
procedure DoIdle(Sender: TObject; var Done: Boolean);
procedure SetActive(const Value: Boolean);
procedure ShowHint(Origin: TPoint; Text: String);
procedure HideHint;
public
function GetWndPropValue(Wnd: HWND; Propname: String): Boolean;
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
property Active: Boolean read FActive write SetActive default true;
property AlwaysShowHint: Boolean read FAlwaysShowHint write FAlwaysShowHint default false;
end;
const
RSOnlyOneHSHintEdit = [COLOR=blue]'Подключается один раз в приложении'[/COLOR];
var
GlobalHSHintEdit: THSHintEdit = nil;
procedure Register;
implementation
uses Forms;
procedure Register;
begin
RegisterComponents('Samples',[THSHintEdit]);
end;
{ THSHintEdit }
constructor THSHintEdit.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
if Assigned(GlobalHSHintEdit) then
raise EHSHintEditException.Create(RSOnlyOneHSHintEdit)
else GlobalHSHintEdit := Self;
SetLength(FBufferArray, 0);
FHintWnd := THintWindow.Create(Self);
FHintWnd.Color := Application.HintColor;
FCanvas := TCanvas.Create;
FAppEvnts := TApplicationEvents.Create(Self);
FAlwaysShowHint := false;
Active := true;
end;
[COLOR=gray]{ Сброс и уничтожение всех объектов, определенных в конструкторе класса }[/COLOR]
destructor THSHintEdit.Destroy;
begin
GlobalHSHintEdit := nil;
FCanvas.Free;
FAppEvnts.Free;
FHintWnd.Free;
inherited Destroy;
end;
[COLOR=gray]{ Собственно вывод хинта }[/COLOR]
procedure THSHintEdit.AdjustHint(Wnd: HWND; Point: TPoint);
var
HintPt: TPoint;
EditRect: TRect;
Len: Integer;
TextWidth: Integer;
BuffArr: Array of Char;
begin
Windows.ScreenToClient(Wnd, Point);
Len := GetWindowTextLength(Wnd);
SetLength(BuffArr, Len + 1);
GetWindowText(Wnd, PChar(BuffArr), Len + 1);
if (PChar(BuffArr) <> PChar(FBufferArray)) then
begin
SetLength(FBufferArray, Len + 1);
PChar(FBufferArray) := PChar(BuffArr);
GetClientRect(Wnd, EditRect);
FCanvas.Handle := GetDC(Wnd);
TextWidth := FCanvas.TextWidth(PChar(BuffArr));
ReleaseDC(Wnd, FCanvas.Handle);
FCanvas.Handle := 0;
if FAlwaysShowHint or ((not FAlwaysShowHint) and (EditRect.Right < TextWidth)) then
begin
HintPt := EditRect.TopLeft;
Windows.ClientToScreen(Wnd, HintPt);
ShowHint(HintPt, PChar(BuffArr));
end
else begin
HideHint;
end;
end;
end;
procedure THSHintEdit.DoIdle(Sender: TObject; var Done: Boolean);
var
Pt: TPoint; [COLOR=gray]{ Адрес структуры, принимающей экранные координаты }[/COLOR]
Handle: HWND; [COLOR=gray]{ Дескриптор окна данного элемента }[/COLOR]
begin
GetCursorPos(Pt); [COLOR=gray]{ Извлечение позиции курсора в координатах экрана }[/COLOR]
Handle := WindowFromPoint(Pt); [COLOR=gray]{ Дескриптор окна - адрес с координатами курсора }[/COLOR]
if Handle <> 0 then
if GetWndPropValue(Handle, [COLOR=blue]'PasswordChar'[/COLOR]) then
AdjustHint(Handle, Pt) [COLOR=gray]{ Переход к выводу подсказки }[/COLOR]
else
HideHint; [COLOR=gray]{ Погасить (не выводить) подсказку }[/COLOR]
end;
[COLOR=gray]{ Процедура записи свойства Active }[/COLOR]
procedure THSHintEdit.SetActive(const Value: Boolean);
begin
if Value <> FActive then
begin
FActive := Value;
if Value then
FAppEvnts.OnIdle := DoIdle
else
FAppEvnts.OnIdle := nil;
end;
end;
[COLOR=gray]{ Проблема здесь }[/COLOR]
function THSHintEdit.GetWndPropValue(Wnd: HWND; PropName: String): Boolean;
var
Atom: TAtom; [COLOR=gray]{ Структурная единица данных в памяти }[/COLOR]
AtomArr: Array[0..31] of Char; [COLOR=gray]{ Форматированный массив атома окна TEdit }[/COLOR]
BuffArr: Array[Byte] of Char; [COLOR=gray]{ Буфер, содержащий имя класса окна }[/COLOR]
Buf: Array[0..31] of Byte; [COLOR=gray]{ Указатель на данные свойства окна TEdit }[/COLOR]
Cls: TClass; [COLOR=gray]{ Тип класса окна }[/COLOR]
Len: Integer; [COLOR=gray]{ Длина адреса свойства окна в байтах }[/COLOR]
Pid: Integer; [COLOR=gray]{ ProcessID }[/COLOR]
PH: Integer; [COLOR=gray]{ ProcessHandle }[/COLOR]
PA: PChar; [COLOR=gray]{ Указатель начала адреса окна TEdit }[/COLOR]
PropInfo: PPropInfo; [COLOR=gray]{ Данные свойства }[/COLOR]
StrValue: String; [COLOR=gray]{ Значение свойства элемента }[/COLOR]
function ReadMem(Addr, Buf: Pointer; Size: Integer): Pointer;
var
W: Cardinal;
begin
Result := nil;
if ReadProcessMemory(PH, Addr, Buf, Size, W) then
Result := Buf;
end;
begin
Result := False;
GetClassName(Wnd, @BuffArr[0], SizeOf(BuffArr));
if (BuffArr <> 'TEdit') then Exit; [COLOR=gray]{ Проверка имени класса. Пока оставлена }[/COLOR]
//Cls := FindClass(StrPas(BuffArr)); [COLOR=gray]{ ???Понятно, что исключение, поскольку TEdit не найден, }[/COLOR]
//PropInfo := GetPropInfo(Cls, PropName); [COLOR=gray]{ соответственно закомментированы строки с PropInfo }[/COLOR]
GetWindowThreadProcessID(Wnd, @Pid);
StrFmt(AtomArr, 'Delphi%.8X', [Pid]);
Atom := GlobalFindAtom(AtomArr);
PA := Pointer(GetProp(Wnd, MakeIntAtom(Atom)));
if Pid = Integer(GetCurrentProcessID) then
PH := GetCurrentProcess
else begin
PH := OpenProcess(PROCESS_VM_READ, False, Pid);
if PH = 0 then Exit;
end;
[COLOR=green](* Пока заремлено для решения???
if LongRec(PropInfo.GetProc).Bytes[3] = $FF then
PA := PA + (Integer(PropInfo.GetProc) and $FFFFFF); { Рассмотрено смещение для поля }
case PropInfo.PropType.Kind of
tkInteger: Result := PInteger (ReadMem(PA, @Buf, SizeOf(Integer)))^;
tkChar: Result := PChar (ReadMem(PA, @Buf, SizeOf(Char)))^;
tkWChar: Result := PWChar (ReadMem(PA, @Buf, SizeOf(WChar)))^;
tkInt64: Result := PInt64 (ReadMem(PA, @Buf, SizeOf(Int64)))^;
tkFloat: Result := PExtended(ReadMem(PA, @Buf, SizeOf(Extended)))^;
tkLString:
begin
PA := PPointer(ReadMem(PA, @Buf, SizeOf(Pointer)))^;
Len := PInteger(ReadMem(PA - 4, @Buf, SizeOf(Integer)))^;
SetLength(StrValue, Len);
ReadMem(PA, Pointer(StrValue), Len);
Result := StrValue;
end;
else
raise Exception.Create('Исключение!');
end;
*)[/COLOR]
CloseHandle(PH);
Result := True;
end;
[COLOR=gray]{ Процедура вывода подсказки Hint в экранную область }[/COLOR]
procedure THSHintEdit.ShowHint(Origin: TPoint; Text: String);
var
R: TRect;
begin
Application.CancelHint;
R := FHintWnd.CalcHintRect(1000, Text, nil);
OffsetRect(R, Origin.X, Origin.Y);
FHintWnd.ActivateHint(R, Text);
SetWindowPos(
FHintWnd.Handle,
HWND_TOPMOST,
R.Left,
R.Top,
FHintWnd.Width,
FHintWnd.Height,
SWP_NOACTIVATE);
end;
[COLOR=gray]{ Процедура сокрытия подсказки Hint }[/COLOR]
procedure THSHintEdit.HideHint;
begin
FHintWnd.ReleaseHandle;
end;
end.
Работает нормально. Проблема в том, что я не хочу выводить его в полях с паролем. Т.е. мне надо
найти свойство PasswordChar и, если там не #0, на AdjustHint не идти.
Так как я наследуюсь от TComponent, естественно, у меня проблема с нахождением PasswordChar.
Могу я это обойти в рамках данного класса и WIN API (допустим, созданием наследника TEdit)?
Короче говоря, как получить с помощью WIN API доступ к свойству PasswordChar?
Приложение мое, но хочется именно на WIN API, возможно, потом понадобится вытягивать еще другие свойства.
С Delphi общаюсь месяц, поэтому прошу строго не судить и помочь по существу. На всякий случай, Delphi 2009.
Также хотелось бы узнать мнение Leo. Заранее всем признателен.
