teutils.pas

这个东西的功能很强大

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

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

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

unit TeUtils;

{$I TeDefine.inc}

interface

uses Windows, Messages, Sysutils, Classes, Graphics, Forms, Controls,
  TeBitmap, TeWinAPI;

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

const
  teUtilsVersion = '4.1.0';
  teUtilsVersionPropText = 'LibUtil Version ' + teUtilsVersion;

type
  TteUtilsVersion = type string;

var
  Sig: PChar = '- ' + teUtilsVersionPropText +
    {$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 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 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(DC: HDC; ARect: TRect; AIcon: TIcon); overload;

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

{ Stream routines }

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

{ Region }

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

{ System }

function GetKeyBoardDelayInterval: integer;
function GetKeyBoardSpeedInterval: integer;

{ Mouse capture }

const
  CaptureHandle: Hwnd = 0;

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

{ Utils }

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

{ System routines }

function HasMMX: Boolean;
procedure EMMS;


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


{ 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;
  Trim(Result);
  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;
  Trim(Result);
  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;
  Trim(Result);
  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;
begin
  Result := ARect;

  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;

function RectInRect(ARect, ABounds: TRect): boolean;
begin
  Result := (ARect.Left >= ABounds.Left) and (ARect.Top >= ABounds.Top) and
    (ARect.Right <= ABounds.Right) and (ARect.Bottom <= ABounds.Bottom);
end;

function CompareRect(Rect1, Rect2: TRect): boolean;
begin
  Result := (Rect1.Left = Rect2.Left) and (Rect1.Top = Rect2.Top) and
    (Rect1.Right = Rect2.Right) and (Rect1.Bottom = Rect2.Bottom);
end;

function PointInPolygon(const P: TPoint; const Points: array of TPoint): boolean;
type
  PPoints = ^TPoints;
  TPoints = array[0..0] of TPoint;
var
  Rgn: HRgn;
begin
  Rgn := CreatePolygonRgn(PPoints(@Points)^, High(Points) + 1, WINDING);
  try
    Result := PtInRegion(Rgn, P.X, P.Y);
  finally
    DeleteObject(Rgn);
  end;
end;

{ Drawing Routines ============================================================}

procedure DrawFrameControlGlyph(Canvas: TCanvas; ARect: TRect; AType, AStyle: cardinal; Color: TColor);
var
  B: TteBitmap;
  Pixel: PteColor;
  CColor: TteColor;
  i, j: integer;
begin
  { Draw only glyph }
  B := TteBitmap.Create;
  B.SetSize(RectWidth(ARect), RectHeight(ARect));

  CColor := teColor(Color);

  DrawFrameControl(B.DC, Rect(0, 0, B.Width, B.Height), AType, AStyle);

  for i := 0 to B.Width - 1 do
    for j := 0 to B.Height - 1 do
    begin
      Pixel := B.PixelPtr[i, j];

      if Pixel^ <> 0 then
        Pixel^ := teTransparent
      else
        Pixel^ := CColor;
    end; 

  B.Transparent := true;
  B.Draw(Canvas, ARect.Left, ARect.Top);

  B.Free;
end;

function DrawText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag: cardinal): integer;
var
  AnsiText: string;
begin
  SetBkMode(ACanvas.Handle, TRANSPARENT);

  if IsWinNT then
    Result := Windows.DrawTextW(ACanvas.Handle, PWideChar(AText), Length(AText), Bounds, Flag)
  else
  begin
    AnsiText := WideCharToString(PWideChar(AText));
    Result := Windows.DrawText(ACanvas.Handle, PChar(AnsiText), Length(AnsiText), Bounds, Flag);
  end;
end;

function DrawText(ACanvas: TCanvas; AText: WideString; X, Y: integer): integer;
var
  R: TRect;
begin
  R := Rect(X, Y, X + TextWidth(ACanvas, AText), Y + TextHeight(ACanvas, AText));
  Result := DrawText(ACanvas, AText, R, 0);
end;

function DrawVerticalText(Canvas: TCanvas; AText: WideString; Bounds: TRect; Flag: cardinal; FromTop: boolean): integer;
var
  R, R1: TRect;
  VertBuf, HorzBuf: TteBitmap;
  i, j: integer;
  HorzPixel: PteColor;
  TempCanvas: TCanvas;
  SaveFont: HFont;
begin
  R := Bounds;

  VertBuf := TteBitmap.Create;
  HorzBuf := TteBitmap.Create;
  SaveFont := SelectObject(HorzBuf.DC, Canvas.Font.Handle);
  try
    HorzBuf.SetSize(RectHeight(R), RectWidth(R));
    VertBuf.SetSize(RectWidth(R), RectHeight(R));

    VertBuf.FillRect(Rect(0, 0, VertBuf.Width, VertBuf.Height), teTransparent);
    HorzBuf.FillRect(Rect(0, 0, HorzBuf.Width, HorzBuf.Height), teTransparent);

    { Draw Horizontaly }
    R1 := Rect(0, 0, HorzBuf.Width, HorzBuf.Height);
    TempCanvas := TCanvas.Create;
    TempCanvas.Handle := HorzBuf.DC;
    Result := DrawText(TempCanvas, AText, R1, Flag);
    TempCanvas.Handle := 0;
    TempCanvas.Free;

    { Rotate }
    for i := 0 to HorzBuf.Width - 1 do
      for j := 0 to HorzBuf.Height - 1 do
      begin
        HorzPixel := HorzBuf.PixelPtr[i, j];
        if HorzPixel^ = teTransparent then Continue;

        if not FromTop then
          VertBuf.Pixels[j, (VertBuf.Height - i)] := HorzPixel^
        else
          VertBuf.Pixels[(VertBuf.Width - j), i] := HorzPixel^;
      end;

    VertBuf.Transparent := true;
    VertBuf.Draw(Canvas, Bounds.Left, Bounds.Top);
  finally
    SelectObject(HorzBuf.DC, SaveFont);
    VertBuf.Free;
    HorzBuf.Free;
  end;
end;

function TextWidth(Canvas: TCanvas; AText: WideString; Flags: Integer = 0): integer;
var
  R: TRect;
  Size: TSize;
  AnsiText: string;
begin
  R := Rect(0, 0, 0, 0);

  if IsWinNT and false then
  begin
    Windows.DrawTextW(Canvas.Handle, PWideChar(AText), Length(AText), R, DT_CALCRECT or Flags);
    Result := R.Right;
  end
  else
  begin
    if Flags = 0 then
    begin
      GetTextExtentPoint32W(Canvas.Handle, PWideChar(AText), Length(AText), Size);
      Result := Size.cx;
    end
    else
    begin
      SetLength(AnsiText, Length(AText));
      WideCharToMultiByte(CP_ACP, WC_COMPOSITECHECK, PWideChar(AText), Length(AText), PChar(AnsiText), Length(AText), nil, nil);
      Windows.DrawText(Canvas.Handle, PChar(AnsiText), Length(AnsiText), R, DT_CALCRECT or Flags);
      Result := R.Right;
    end;
  end;
end;

function TextHeight(Canvas: TCanvas; AText: WideString): integer;
var
  Size: TSize;
begin
  GetTextExtentPoint32W(Canvas.Handle, PWideChar(AText), Length(AText), Size);
  Result := Size.cy;
end;

procedure MoveTo(Canvas: TCanvas; X, Y: integer);
begin
  Canvas.MoveTo(X, Y);
end;

procedure LineTo(Canvas: TCanvas; X, Y: integer; Color: TColor);
begin
  Canvas.Pen.Style := psSolid;
  Canvas.Pen.Color := Color;
  Canvas.LineTo(X, Y);
end;

procedure DrawEdge(Canvas: TCanvas; Rect: TRect; RaisedColor, SunkenColor: TColor);
begin
  Canvas.Brush.Style := bsClear;