be_utils.pas

KSDev.BlockEngine.v3.03.rar 界面控件

{==============================================================================

  Utilites
  Copyright (C) 2000-2001 by Evgeny Kryukov
  All rights reserved

  All contents of this file and all other files included in this archive
  are Copyright (C) 2001 Evgeny Kryukov. Use and/or distribution of
  them requires acceptance of the License Agreement.

  See License.txt for licence information

===============================================================================}

unit be_utils;

{$I be_define.inc}

interface

uses Windows, Messages, Sysutils, Classes, Graphics, Forms, Controls,
  be_bitmap, be_winapi;

{!============================================================================!}

const
  beUtilsVersion = '5.0';
  beUtilsVersionPropText = 'LibUtil Version ' + beUtilsVersion;

type
  TbeUtilsVersion = type string;

var
  SigUtils: PChar = '- ' + beUtilsVersionPropText +
    {$IFDEF KS_DELPHI4} ' - D4 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER4} ' - CB4 - ' + {$ENDIF}
    {$IFDEF KS_DELPHI5} ' - D5 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER5} ' - CB5 - '+ {$ENDIF}
    {$IFDEF KS_DELPHI6} ' - D6 - '+ {$ENDIF}
    {$IFDEF KS_CBUILDER6} ' - CB6 - '+ {$ENDIF}
    {$IFDEF KS_DELPHI7} ' - D7 - '+ {$ENDIF}
    'Copyright (C) 1998-2003 by Evgeny Kryukov -';


{ Strings functions }

type

  TTokenSeparators = set of char;

function GetToken(var S: string): string; overload;
function GetToken(var S: string; Separators: string): string; overload;
function GetToken(var S: string; Separators: TTokenSeparators): string; overload;

function RectToString(R: TRect): string;
function StringToRect(S: string): TRect;

function FormatStr(DC: HDC; S: WideString; Width: integer): WideString; overload;

{ Rect, Point and Polygon }

function RectWidth(R: TRect): integer;
function RectHeight(R: TRect): integer;
function RectHCenter(var R: TRect; Bounds: TRect): TRect;
function RectVCenter(var R: TRect; Bounds: TRect): TRect;
function RectCenter(var R: TRect; Bounds: TRect): TRect;
function RectOffset(ARect: TRect; Offset: integer): TRect;
function IsRectEmpty(Rect: TRect): boolean;
function CompareRect(Rect1, Rect2: TRect): boolean;
function MarginRect(ARect, AMargin: TRect): TRect;
function RectInRect(ARect, ABounds: TRect): boolean;

function PointInPolygon(const P: TPoint; const Points: array of TPoint): boolean;

{ Drawing routines }

procedure DrawFrameControlGlyph(Canvas: TCanvas; ARect: TRect; AType, AStyle: cardinal; Color: TColor);

function DrawText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag: cardinal): integer; overload;
function DrawText(ACanvas: TCanvas; AText: WideString; X, Y: integer): integer; overload;
function DrawVerticalText(Canvas: TCanvas; AText: WideString; Bounds: TRect; Flag: cardinal; FromTop: boolean): integer;

function TextWidth(Canvas: TCanvas; AText: WideString; Flags: Integer = 0): integer;
function TextHeight(Canvas: TCanvas; AText: WideString): integer;

procedure MoveTo(Canvas: TCanvas; X, Y: integer);
procedure LineTo(Canvas: TCanvas; X, Y: integer; Color: TColor);

procedure DrawEdge(Canvas: TCanvas; Rect: TRect; RaisedColor, SunkenColor: TColor); overload;
procedure DrawEdge(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer; RaisedColor, SunkenColor: TColor); overload;

procedure DrawRect(Canvas: TCanvas; Rect: TRect; Color: TColor); overload;
procedure DrawRect(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer; Color: TColor); overload;

procedure DrawFocusRect(Canvas: TCanvas; Rect: TRect; Color: TColor);

procedure FillRect(Canvas: TCanvas; Rect: TRect; Color: TColor); overload;
procedure FillRect(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer; Color: TColor); overload;
procedure FillRect(DC: HDC; ALeft, ATop, ARight, ABottom: integer; Color: TColor); overload;

procedure FillEllipse(Canvas: TCanvas; Rect: TRect; Color: TColor); overload;
procedure FillEllipse(Canvas: TCanvas; ALeft, ATop, ARight, ABottom: integer; Color: TColor); overload;

procedure DrawRoundRect(Canvas: TCanvas; ARect: TRect; Radius: integer; Color: TColor);
procedure FillRoundRect(Canvas: TCanvas; ARect: TRect; Radius: integer; Color: TColor);
procedure FillGradientRect(Canvas: TCanvas; ARect: TRect; BeginColor, EndColor: TColor; Vertical: boolean);
procedure FillRadialGradientRect(Canvas: TCanvas; Rect: TRect; BeginColor,
  EndColor: TColor; Pos: TPoint);
procedure FillHalftoneRect(Canvas: TCanvas; ARect: TRect; Color, HalfColor: TColor);
procedure FillAlphaRect(Canvas: TCanvas; ARect: TRect; Color: TColor; Alpha: integer);

procedure DrawPolygon(Canvas: TCanvas; Points: array of TPoint; Color: TColor);
procedure FillPolygon(Canvas: TCanvas; Points: array of TPoint; Color: TColor);
procedure FillHalftonePolygon(Canvas: TCanvas; Points: array of TPoint; Color, HalfColor: TColor);

procedure DrawIcon(Canvas: TCanvas; ARect: TRect; AIcon: TIcon); overload;
procedure DrawIcon(Canvas: TCanvas; ARect: TRect; AIcon: Cardinal); overload;
procedure DrawIcon(DC: HDC; ARect: TRect; AIcon: TIcon); overload;
procedure DrawIcon(DC: HDC; ARect: TRect; AIcon: Cardinal); overload;

procedure DrawGlyphShadow(Canvas: TCanvas; X, Y: integer; Glyph: TbeBitmap; Color: TColor);

{ Stream routines }

function ReadString(S: TStream): string;
procedure WriteString(S: TStream; Value: string);

{ Api }

function GetWndClassName(AHandle: HWnd): string;
function GetWndText(AHandle: HWnd): string;

{ Region }

function CreateRegionFromBitmap(Bitmap: TbeBitmap; Left, Top: integer): HRgn;

{ Screen }
var
  CPixelFormat: TPixelFormat = pfCustom;

function GetPixelFormat: TPixelFormat;

{ System }

function GetKeyBoardDelayInterval: integer;
function GetKeyBoardSpeedInterval: integer;

{ Mouse capture }

const
  CaptureHandle: Hwnd = 0;

procedure CaptureMouse(const Wnd: HWND);
procedure EndCapture;

{ Unicode routines }

{ Utils }

function StringToWideString(CodePage: Cardinal; const s: String): WideString;

{$IFNDEF KS_COMPILER5_UP}
procedure FreeAndNil(var Obj);
{$ENDIF}

{ System routines }

function HasMMX: Boolean;
procedure EMMS;


implementation {===============================================================}


{ Api }

var
  Buf: array [0..1000] of char;
  
function GetWndClassName(AHandle: HWnd): string;
begin
  if GetClassName(AHandle, @Buf, 1000) > 0 then
    Result := Buf
  else
    Result := '';
end;

function GetWndText(AHandle: HWnd): string;
begin
  if GetWindowText(AHandle, @Buf, 1000) > 0 then
    Result := Buf
  else
    Result := '';
end;

{ Utils =======================================================================}

{$IFNDEF KS_COMPILER5_UP}
procedure FreeAndNil(var Obj);
var
  P: TObject;
begin
  P := TObject(Obj);
  TObject(Obj) := nil;
  P.Free;
end;
{$ENDIF}

{ Capture =====================================================================}

const

  CaptureCount: integer = 0;

procedure CaptureMouse(const Wnd: HWND);
begin
  if CaptureCount = 0 then
  begin
    CaptureHandle := Wnd;
    SetCapture(CaptureHandle);
  end;
  Inc(CaptureCount);
end;

procedure EndCapture;
begin
  Dec(CaptureCount);
  if CaptureCount = 0 then
  begin
    if GetCapture = CaptureHandle then
      ReleaseCapture;
    CaptureHandle := 0;
  end;
end;

{ Strings functions ===========================================================}

function GetToken(var S: string): string;
{ Return first token and remove it from S }
var
  i: byte;
  CopyS: string;
begin
  Result := '';
  CopyS := S;
  for i := 1 to Length(CopyS) do
  begin
    Delete(S, 1, 1);
    if CopyS[i] in [',', ' ', '(', ')', ';', ':', '='] then Break;
    Result := Result + CopyS[i];
  end;
  Result := Trim(Result);
  S := Trim(S);
end;

function GetToken(var S: string; Separators: string): string;
var
  i: byte;
  CopyS: string;
begin
  Result := '';
  CopyS := S;
  for i := 1 to Length(CopyS) do
  begin
    Delete(S, 1, 1);
    if Pos(CopyS[i], Separators) > 0 then Break;
    Result := Result + CopyS[i];
  end;
  Result := Trim(Result);
  S := Trim(S);
end;

function GetToken(var S: string; Separators: TTokenSeparators): string;
var
  i: byte;
  CopyS: string;
begin
  Result := '';
  CopyS := S;
  for i := 1 to Length(CopyS) do
  begin
    Delete(S, 1, 1);
    if CopyS[i] in Separators then Break;
    Result := Result + CopyS[i];
  end;
  Result := Trim(Result);
  S := Trim(S);
end;

function RectToString(R: TRect): string;
{ Convert TRect to string }
begin
  Result := '(' + IntToStr(R.Left) + ',' + IntToStr(R.Top) + ',' + IntToStr(R.Right) + ',' +
    IntToStr(R.Bottom) + ')';
end;

function StringToRect(S: string): TRect;
{ Convert string to TRect }
begin
  try
    Result.Left := StrToInt(GetToken(S));
    Result.Top := StrToInt(GetToken(S));
    Result.Right := StrToInt(GetToken(S));
    Result.Bottom := StrToInt(GetToken(S));
  except
    Result := Rect(0, 0, 0, 0);
  end;
end;

function FormatStr(DC: HDC; S: WideString; Width: integer): WideString;
var
  i: integer;
  Size: TSize;
  Ts: WideString;
begin
  Result := S;
  GetTextExtentPoint32W(DC, PWideChar(S), Length(S), Size);

  if Size.cx <= Width then Exit;

  Result := '';
  for i := 1 to Length(S) do
  begin
    Ts := Result + S[i] + '...';
    GetTextExtentPoint32W(DC, PWideChar(Ts), Length(Ts), Size);
    if Size.cx > Width then Break;
    Result := Result + S[i];
  end;
  Result := Result + '...'
end;

{ Rect and Point ==============================================================}

function RectWidth(R: TRect): integer;
begin
  Result := R.Right - R.Left;
end;

function RectHeight(R: TRect): integer;
begin
  Result := R.Bottom - R.Top;
end;

function RectVCenter(var R: TRect; Bounds: TRect): TRect;
begin
  OffsetRect(R, -R.Left, -R.Top);
  OffsetRect(R, 0, (RectHeight(Bounds) - RectHeight(R)) div 2);
  OffsetRect(R, Bounds.Left, Bounds.Top);

  Result := R;
end;

function RectHCenter(var R: TRect; Bounds: TRect): TRect;
begin
  OffsetRect(R, -R.Left, -R.Top);
  OffsetRect(R, (RectWidth(Bounds) - RectWidth(R)) div 2, 0);
  OffsetRect(R, Bounds.Left, Bounds.Top);

  Result := R;
end;

function RectCenter(var R: TRect; Bounds: TRect): TRect;
begin
  OffsetRect(R, -R.Left, -R.Top);
  OffsetRect(R, (RectWidth(Bounds) - RectWidth(R)) div 2, (RectHeight(Bounds) - RectHeight(R)) div 2);
  OffsetRect(R, Bounds.Left, Bounds.Top);

  Result := R;
end;

function RectOffset(ARect: TRect; Offset: integer): TRect;
begin
  Result.Top := ARect.Top - Offset;
  Result.Left := ARect.Left - Offset;
  Result.Bottom := ARect.Bottom + Offset;
  Result.Right := ARect.Right + Offset;
end;

function IsRectEmpty(Rect: TRect): boolean;
begin
  Result := (RectWidth(Rect) <= 0) or (RectHeight(Rect) <= 0); 
end;

function MarginRect(ARect, AMargin: TRect): TRect;
var
  Dx: single;
begin
  Result := ARect;

  if (AMargin.Left > RectWidth(ARect)) or (AMargin.Right > RectWidth(ARect)) or (AMargin.Left + AMargin.Right > RectWidth(ARect)) then
  begin
    if (AMargin.Left + AMargin.Right) <> 0 then
      Dx := RectWidth(ARect) / (AMargin.Left + AMargin.Right)
    else
      Dx := 1;
    Result.Left := Result.Left + Round(AMargin.Left * Dx);
    Result.Top := Result.Top + AMargin.Top;
    Result.Right := Result.Right - Round(AMargin.Right * Dx);
    Result.Bottom := Result.Bottom - AMargin.Bottom;
  end
  else
  if (AMargin.Top > RectHeight(ARect)) or (AMargin.Bottom > RectHeight(ARect)) or (AMargin.Top + AMargin.Bottom > RectHeight(ARect)) then
  begin
    if (AMargin.Top + AMargin.Bottom) <> 0 then
      Dx := RectHeight(ARect) / (AMargin.Top + AMargin.Bottom)
    else
      Dx := 1;
    Result.Left := Result.Left + AMargin.Left;
    Result.Top := Result.Top + Round(AMargin.Top * Dx);
    Result.Right := Result.Right - AMargin.Right;
    Result.Bottom := Result.Bottom - Round(AMargin.Bottom * Dx);
  end
  else
  begin
    Result.Left := Result.Left + AMargin.Left;
    Result.Top := Result.Top + AMargin.Top;
    Result.Right := Result.Right - AMargin.Right;
    Result.Bottom := Result.Bottom - AMargin.Bottom;
  end;
end;

function RectInRect(ARect, ABounds: TRect): boolean;