Советы по Delphi. Версия 1.4.3 от 1.1.2001 - Валентин Озеров

  CoUninitialize;

 end;

end;

Разное 

`Устойчивые` всплывающие подсказки

На TabbedNotebook у меня есть множество компонентов TEdit. Я изменяю цвет компонентов TEdit на желтый и назначаю свойству Hint компонента строчку предупреждения, если поле редактирования содержит неверные данные.

Поведение окна со всплывающей подсказкой (hintwindow) позволяет делать его видимым только тогда, когда курсор мыши находится в области элемента управления. Но мой заказчик хочет видеть подсказки все время, пока поле редактирования имеет фокус.

Я не знаю как изменить поведение всплывающей подсказки, заданное по умолчанию. Я знаю что это возможно, но кто мне подскажет как?

Ниже приведен модуль, содержащий новый тип hintwindow, TFocusHintWindow. Когда вы "просите" TFocusHintWindow появиться, он появляется ниже элемента управления, имеющего фокус. Для показа и скрытия достаточно следующих команд:

FocusHintWindow.Showing := True;

FocusHintWindow.Showing := False;

Пример того, как это можно использовать, содержится в комментариях к модулю. Это просто.

unit FHintWin;

{ -----------------------------------------------------------

 TFocusHintWindow --

 Вот пример того, как можно использовать TFocusHintWindow.

 Данный пример выводит всплывающую подсказку ниже любого

 TEdit, имеющего фокус. В противном случае выводится

 стандартная подсказка Windows.

unit Unit1;

interface

uses SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, FHintWin;

type TForm1 = class(TForm)

 procedure FormCreate(Sender: TObject);

private

 FocusHintWindow: TFocusHintWindow;

 procedure AppIdle(Sender: TObject; var Done: Boolean);

 procedure AppShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);

end;

implementation

procedure TForm1.FormCreate(Sender: TObject);

begin

 Application.OnIdle := AppIdle;

 Application.OnShowHint := AppShowHint;

 FocusHintWindow := TFocusHintWindow.Create(Self);

end;

procedure TForm1.AppIdle(Sender: TObject; var Done: Boolean);

begin

 FocusHintWindow.Showing := Screen.ActiveControl is TEdit;

end;

procedure TForm1.AppShowHint(var HintStr: string; var CanShow: Boolean; var HintInfo: THintInfo);

begin

 CanShow := not FocusHintWindow.Showing;

end;

end.

----------------------------------------------------------- }

interface

uses SysUtils, WinTypes, WinProcs, Classes, Controls, Forms;

type TFocusHintWindow = class(THintWindow)

private

 FShowing: Boolean;

 HintControl: TControl;

protected

 procedure SetShowing(Value: Boolean);

 function CalcHintRect(Hint: string): TRect;

 procedure Appear;

 procedure Disappear;

public

 property Showing: Boolean read FShowing write SetShowing;

end;

implementation

function TFocusHintWindow.CalcHintRect(Hint: string): TRect;

var Buffer: array[Byte] of Char;

begin

 Result := Bounds(0, 0, Screen.Width, 0);

 DrawText(Canvas.Handle, StrPCopy(Buffer, Hint), -1, Result, DT_CALCRECT or DT_LEFT or DT_WORDBREAK or DT_NOPREFIX);

 with HintControl, ClientOrigin do OffsetRect(Result, X, Y + Height + 6);

 Inc(Result.Right, 6);

 Inc(Result.Bottom, 2);

end;

procedure TFocusHintWindow.Appear;

var

 Hint: string;

 HintRect: TRect;

begin

 if (Screen.ActiveControl = HintControl) then Exit;

 HintControl := Screen.ActiveControl;

 Hint := GetShortHint(HintControl.Hint);

 HintRect := CalcHintRect(Hint);

 ActivateHint(HintRect, Hint);

 FShowing := True;

end;

procedure TFocusHintWindow.Disappear;

begin

 HintControl := nil;

 ShowWindow(Handle, SW_HIDE);

 FShowing := False;

end;

procedure TFocusHintWindow.SetShowing(Value: Boolean);

begin

 if Value then Appear else Disappear;

end;

end.

– Ed Jordan

Вызов 16-разрядного кода из 32-разрядного

Andrew Pastushenko пишет:

Посылаю код для определения системных ресурсов (как в "Индикаторе ресурсов"). Использовалась статья "Calling 16-bit code from 32-bit in Windows 95".

{ GetFeeSystemResources routine for 32-bit Delphi.

  Works only under Windows 9x }

unit SysRes32;

interface

const

 //Constants whitch specifies the type of resource to be checked

 GFSR_SYSTEMRESOURCES = $0000;

 GFSR_GDIRESOURCES    = $0001;

 GFSR_USERRESOURCES   = $0002;

// 32-bit function exported from this unit

function GetFeeSystemResources(SysResource: Word): Word;

implementation

uses SysUtils, Windows;

type

 //Procedural variable for testing for a nil

 TGetFSR = function(ResType: Word): Word; stdcall;

 //Declare our class exeptions

 EThunkError = class(Exception);

 EFOpenError = class(Exception);

var

 User16Handle : THandle = 0;

 GetFSR       : TGetFSR = nil;

//Prototypes for some undocumented API

function LoadLibrary16(LibFileName: PAnsiChar): THandle; stdcall; external kernel32 index 35;

function FreeLibrary16(LibModule: THandle): THandle; stdcall; external kernel32 index 36;

function GetProcAddress16(Module: THandle; ProcName: LPCSTR): TFarProc;stdcall; external kernel32 index 37;

procedure QT_Thunk; cdecl; external 'kernel32.dll' name 'QT_Thunk';

{$StackFrames On}

function GetFeeSystemResources(SysResource: Word): Word;

var EatStackSpace: String[$3C];

begin

 // Ensure buffer isn't optimised away

 EatStackSpace := '';

 @GetFSR:=GetProcAddress16(User16Handle, 'GETFREESYSTEMRESOURCES');

 if  Assigned(GetFSR) then  //Test result for nil

  asm

   //Manually push onto the stack type of resource to be checked first

   push  SysResource

   //Load routine address into EDX

   mov   edx, [GetFSR]

   //Call routine

   call  QT_Thunk

   //Assign result to the function

   mov   @Result, ax

  end

 else raise EFOpenError.Create('GetProcAddress16 failed!');

end;

initialization

 //Check Platform for Windows 9x

 if Win32Platform <> VER_PLATFORM_WIN32_WINDOWS then raise EThunkError.Create('Flat thunks only supported under Windows 9x');

 //Load 16-bit DLL (USER.EXE)

 User16Handle:= LoadLibrary16(PChar('User.exe'));

 if User16Handle < 32 then raise EFOpenError.Create('LoadLibrary16 failed!');

finalization

 //Release 16-bit DLL when done

 if User16Handle  <> 0 then FreeLibrary16(User16Handle);

end.

Как проверить, имеем ли мы административные привилегии в системе?

Nomadic пишет:

// Routine: check if the user has administrator provileges

// Was converted from C source by Akzhan Abdulin. Not properly tested.

type PTOKEN_GROUPS = TOKEN_GROUPS^;

function RunningAsAdministrator(): Boolean;

var

 SystemSidAuthority: SID_IDENTIFIER_AUTHORITY = SECURITY_NT_AUTHORITY;

 psidAdmin: PSID;

 ptg: PTOKEN_GROUPS = nil;

 htkThread: Integer; { HANDLE }

 cbTokenGroups: Longint; { DWORD }

 iGroup: Longint; { DWORD }

 bAdmin: Boolean;

begin

 Result := false;

 if not OpenThreadToken(GetCurrentThread(),      // get security token

  TOKEN_QUERY, FALSE, htkThread) then

  if GetLastError() = ERROR_NO_TOKEN then begin

  if not OpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, htkThread) then Exit;

  end else Exit;

  if GetTokenInformation(htkThread,            // get #of groups

   TokenGroups, nil, 0, cbTokenGroups) then Exit;

  if GetLastError() <> ERROR_INSUFFICIENT_BUFFER then Exit;

  ptg := PTOKEN_GROUPS(getmem(cbTokenGroups));

  if not Assigned(ptg) then Exit;

  if not GetTokenInformation(htkThread,           // get groups

   TokenGroups, ptg, cbTokenGroups, cbTokenGroups) then Exit;

  if not AllocateAndInitializeSid(SystemSidAuthority, 2, SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, psidAdmin) then Exit;

  iGroup := 0;

  while iGroup < ptg^.GroupCount do // check administrator group