bsutils.pas

Delphi开发的图象处理软件

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 2.74                                                }
{                                                                   }
{       Copyright (c) 2000-2004 Almediadev                          }
{       ALL RIGHTS RESERVED                                         }
{                                                                   }
{       Home:  http://www.almdev.com                                }
{       Support: [e-mail]                                 }
{                                                                   }
{*******************************************************************}

unit bsUtils;

{$P+,S-,W-,R-}
{$WARNINGS OFF}
{$HINTS OFF}

interface

{$R-}

uses
  Windows, Controls, Messages, SysUtils, Classes, Graphics, IniFiles;

const
  maxi = 10000;

  // xp office color consts

  BS_XP_BTNFRAMECOLOR = 8388608;
  BS_XP_BTNACTIVECOLOR = 13811126;
  BS_XP_BTNDOWNCOLOR = 11899781;

type
  TCharSet = set of char;


{ TbsFBitmap }

  TFBColor  = record b,g,r:Byte end;
  PFBColor  =^TFBColor;
  TBLine    = array[0..0]of TFBColor;
  PBLine    =^TBLine;
  TPLines  = array[0..0]of PBLine;
  PPLines  =^TPLines;

  TbsFBitmap = class
  private
    Bits:   Pointer;
    procedure   Initialize;
  public
    Pixels: PPLines;
    Gap,
    RowInc,
    Size,
    Width,
    Height: Integer;
    Handle,
    hDC:        Integer;
    bmInfo:     TBitmapInfo;
    bmHeader:   TBitmapInfoHeader;
    constructor Create(HBmp:Integer);
    destructor  Destroy; override;
  end;

  TRectArray = array[0..maxi] of TRect;
  

//
function EqRects(R1, R2: TRect): Boolean;
function NullRect: TRect;
function IsNullRect(R: TRect): Boolean;
function IsNullPoint(P: TPoint): Boolean;
function RectInRect(R1, R2: TRect): Boolean;
//
function RectWidth(R: TRect): Integer;
function RectHeight(R: TRect): Integer;
function RectToCenter(var R: TRect; Bounds: TRect): TRect;
// Region functions
function CreateRgnFromBmp(B: TBitmap; XO, YO: Integer; var RgnData: PRgnData): integer;
// Stream functions
procedure WriteStringToStream(Str: String; S: TStream);
procedure ReadStringFromStream(var Str: String; S: TStream);
// Skin functions
function GetRect(S: String): TRect;
function GetPoint(S: String): TPoint;
function SetRect(R: TRect): String;

procedure CreateSkinBorderImages(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  LeftB, TopB, RightB, BottomB, SB: TBitMap; R: TRect; AW, AH: Integer;
  LS, TS, RS, BS: Boolean);

procedure CreateSkinImageBS(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  B, SB: TBitMap; R: TRect; AW, AH: Integer; DrawClient: Boolean;
  LS, TS, RS, BS: Boolean);

procedure CreateSkinImage(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  B, SB: TBitMap; R: TRect; AW, AH: Integer; DrawClient: Boolean);

procedure CreateSkinImage2(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  B, SB: TBitMap; R: TRect; AW, AH: Integer; DrawClient: Boolean);

procedure CreateHSkinImage(LO, RO: Integer;
  B, SB: TBitMap; R: TRect; AW, AH: Integer);

procedure CreateHSkinImage2(LO, RO: Integer;
  B, SB: TBitMap; R: TRect; AW, AH: Integer);

procedure CreateHSkinImage3(LO, RO: Integer;
  B, SB: TBitMap; R: TRect; AW, AH: Integer);

procedure CreateVSkinImage(TpO, BO: Integer;
  B, SB: TBitMap; R: TRect; AW, AH: Integer);
  
procedure CreateSkinMask(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  FMask, RMTop, RMLeft, RMRight, RMBottom: TBitMap; AW, AH: Integer);

procedure CreateSkinSimplyRegion(var FRgn: HRgn; FMask: TBitMap);

procedure CreateSkinRegion(var FRgn: HRgn;
  LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  FMask: TBitMap; AW, AH: Integer);

procedure DrawGlyph(Cnvs: TCanvas; X, Y: Integer; FGlyph: TBitMap;
                    FNumGlyphs, FGlyphNum: Integer);

// IniFile funcitons
function ReadRect(IniFile: TCustomIniFile; Section: String; Ident: String): TRect;
function ReadPoint(IniFile: TCustomIniFile; Section: String; Ident: String): TPoint;
function ReadBoolean(IniFile: TCustomIniFile; Section: String; Ident: String): Boolean;

function ReadFontStyles(IniFile: TCustomIniFile;
                        Section: String; Ident: String): TFontStyles;
procedure ReadStrings(IniFile: TCustomIniFile;
                      Section: String; Ident: String; S: TStrings);
procedure ReadStrings1(IniFile: TCustomIniFile;
                       Section: String; Ident: String; S: TStrings);
function ReadAlignment(IniFile: TCustomIniFile;
                       Section: String; Ident: String): TAlignment;
procedure WriteAlignment(IniFile: TCustomIniFile;
                         Section: String; Ident: String; A: TAlignment);
procedure WriteRect(IniFile: TCustomIniFile; Section: String; Ident: String; R: TRect);
procedure WritePoint(IniFile: TCustomIniFile; Section: String; Ident: String; P: TPoint);
procedure WriteBoolean(IniFile: TCustomIniFile; Section: String; Ident: String; B: Boolean);
procedure WriteFontStyles(IniFile: TCustomIniFile;
                          Section: String; Ident: String; FS: TFontStyles);
procedure WriteStrings(IniFile: TCustomIniFile;
                       Section: String; Ident: String; S: TStrings);
procedure WriteStrings1(IniFile: TCustomIniFile;
                        Section: String; Ident: String; S: TStrings);

procedure GetScreenImage(X, Y: Integer; B: TBitMap);

procedure GetWindowsVersion(var Major, Minor: Integer);

function CheckW2KWXP: Boolean;

function CheckWXP: Boolean;

procedure SetAlphaBlendTransparent(WHandle: HWnd; Value: Byte);

procedure Frm3D(Canvas: TCanvas; Rect: TRect; TopColor, BottomColor: TColor);
procedure DrawRadioImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawCheckImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawArrowImage(Cnvs: TCanvas; R: TRect; Color: TColor; Code: Integer);
procedure DrawTrackArrowImage(Cnvs: TCanvas; R: TRect; Color: TColor);
function PointInRect(R: TRect; P: TPoint): Boolean;

procedure BSDrawText(Cnvs: TCanvas; S: String; R: TRect);
procedure BSDrawText2(Cnvs: TCanvas; S: String; R: TRect);
procedure BSDrawText3(Cnvs: TCanvas; S: String; R: TRect; HorOffset: Integer);

procedure DrawCloseImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawRCloseImage(C: TCanvas; R: TRect; Color: TColor);
procedure DrawMinimizeImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawMaximizeImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawRollUpImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawRestoreRollUpImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawRestoreImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawSysMenuImage(C: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawMTImage(C: TCanvas; X, Y: Integer; Color: TColor);

function ExtractDay(ADate: TDateTime): Word;
function ExtractMonth(ADate: TDateTime): Word;
function ExtractYear(ADate: TDateTime): Word;
function IsLeapYear(AYear: Integer): Boolean;
function DaysPerMonth(AYear, AMonth: Integer): Integer;

function ReplaceStr(const S, Srch, Replace: string): string;
function Max(A, B: Longint): Longint;
function Min(A, B: Longint): Longint;

procedure CorrectTextbyWidth(C: TCanvas; var S: String; W: Integer);

procedure GetParentImage(Control: TControl; Dest: TCanvas);

function GetMonitorWorkArea(const W: HWND; const WorkArea: Boolean): TRect;
function GetPrimaryMonitorWorkArea(const WorkArea: Boolean): TRect;

implementation

uses Forms, Consts;

const
  LWA_ALPHA = $2;

type
  TParentControl = class(TWinControl);

procedure GetParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
  Ctrl: TControl;
begin
  if Control.Parent = nil then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  SelfR := Bounds(Control.Left, Control.Top, Control.Width, Control.Height);
  X := -Control.Left; Y := -Control.Top;
  // Copy parent control image
  if Control.Parent is TForm
  then
    begin
      SaveIndex := SaveDC(DC);
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
         Control.Parent.ClientHeight);
      SendMessage(Control.Parent.Handle, WM_ERASEBKGND, DC, 0);
      RestoreDC(DC, SaveIndex);
    end
  else
    begin
      SaveIndex := SaveDC(DC);
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
      Control.Parent.ClientHeight);
      TParentControl(Control.Parent).PaintWindow(DC);
      SendMessage(Control.Parent.Handle, WM_ERASEBKGND, DC, 0);
      RestoreDC(DC, SaveIndex);
    end;
end;

procedure CorrectTextbyWidth(C: TCanvas; var S: String; W: Integer);
var
  j: Integer;
begin
  j := Length(S);
  with C do
  begin
    if TextWidth(S) > w
    then
      begin
        repeat
          Delete(S, j, 1);
          Dec(j);
        until (TextWidth(S + '...') <= w) or (S = '');
        S := S + '...';
      end;
  end;
end;

function Max(A, B: Longint): Longint;
begin
  if A > B then Result := A
  else Result := B;
end;

function Min(A, B: Longint): Longint;
begin
  if A < B then Result := A
  else Result := B;
end;

function ReplaceStr(const S, Srch, Replace: string): string;
var
  I: Integer;
  Source: string;
begin
  Source := S;
  Result := '';
  repeat
    I := Pos(Srch, Source);
    if I > 0 then begin
      Result := Result + Copy(Source, 1, I - 1) + Replace;
      Source := Copy(Source, I + Length(Srch), MaxInt);
    end
    else Result := Result + Source;
  until I <= 0;
end;

procedure BSDrawText(Cnvs: TCanvas; S: String; R: TRect);
begin
  DrawText(Cnvs.Handle, PChar(S), Length(S), R,
    DT_VCENTER or DT_SINGLELINE or DT_LEFT);
end;

procedure BSDrawText2(Cnvs: TCanvas; S: String; R: TRect);
var
  TX, TY: Integer;
begin
  TX := R.Left + 2;
  TY := R.Top + RectHeight(R) div 2 - Cnvs.TextHeight(S) div 2;
  Cnvs.TextRect(R, TX, TY, S);
end;

procedure BSDrawText3(Cnvs: TCanvas; S: String; R: TRect; HorOffset: Integer);
var
  TX, TY: Integer;
begin
  TX := R.Left + 2 + HorOffset;
  TY := R.Top + RectHeight(R) div 2 - Cnvs.TextHeight(S) div 2;
  Cnvs.TextRect(R, TX, TY, S);
end;

procedure DrawTrackArrowImage(Cnvs: TCanvas; R: TRect; Color: TColor);
var
  X, Y, i: Integer;
begin
  X := R.Left + RectWidth(R) div 2;
  Y := R.Top + RectHeight(R) div 2 + 2;
  for i := 2 downto 0 do
  with Cnvs do
  begin
    Pen.Color := Color;
    MoveTo(X - i, Y - i);
    LineTo(X + i + 1, Y - i);
  end;
end;

procedure DrawArrowImage(Cnvs: TCanvas; R: TRect; Color: TColor; Code: Integer);
var
  i: Integer;
  X, Y: Integer;
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    case Code of
      1:
        begin
          X := R.Left + RectWidth(R) div 2 - 2;
          Y := R.Top + RectHeight(R) div 2;
          for i := 0 to 3 do
          begin
            MoveTo(X + i, Y - i);
            LineTo(X + i, Y + i + 1);
          end;
        end;
      2:
        begin
          X := R.Left + RectWidth(R) div 2 + 2;
          Y := R.Top + RectHeight(R) div 2;
          for i := 3 downto 0 do
           begin
             MoveTo(X - i, Y + i);
             LineTo(X - i, Y - i - 1);
           end;
        end;
      3:
        begin
          X := R.Left + RectWidth(R) div 2;
          Y := R.Top + RectHeight(R) div 2 - 2;
          for i := 0 to 3 do
          begin
            MoveTo(X - i, Y + i);
            LineTo(X + i + 1, Y + i);
          end;
        end;
      4:
        begin
          X := R.Left + RectWidth(R) div 2;
          Y := R.Top + RectHeight(R) div 2 + 2;
          for i := 3 downto 0 do
          begin
            MoveTo(X - i, Y - i);
            LineTo(X + i + 1, Y - i);
          end;  
        end;
    end;
  end;
end;

procedure DrawRadioImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    Brush.Color := Color;
    Rectangle(X, Y, X + 6, Y + 6);
  end;
end;

procedure DrawCheckImage(Cnvs: TCanvas; X, Y: Integer; Color: TColor);
var
  i: Integer;
begin
  with Cnvs do
  begin
    Pen.Color := Color;
    for i := 0 to 2 do
    begin
      MoveTo(X, Y + 5 - i);
      LineTo(X + 2, Y + 7 - i);
      LineTo(X + 7, Y + 2 - i);
    end;
  end;
end;

procedure Frm3D;
  procedure DoRect;
  var
    TopRight, BottomLeft: TPoint;
  begin
    with Canvas, Rect do
    begin
      TopRight.X := Right;
      TopRight.Y := Top;
      BottomLeft.X := Left;
      BottomLeft.Y := Bottom;
      Pen.Color := TopColor;
      PolyLine([BottomLeft, TopLeft, TopRight]);
      Pen.Color := BottomColor;
      Dec(BottomLeft.X);
      PolyLine([TopRight, BottomRight, BottomLeft]);
    end;
  end;

begin
  Canvas.Pen.Width := 1;
  Dec(Rect.Bottom); Dec(Rect.Right);
  DoRect;
end;

procedure GetWindowsVersion(var Major, Minor: Integer);
var
  Ver : Longint;
begin
  Ver := GetVersion;
  Major := LoByte(LoWord(Ver));
  Minor := HiByte(LoWord(Ver));
end;

function CheckWXP: Boolean;
var
  Major, Minor : Integer;
begin
  GetWindowsVersion(major, minor);
  Result := (major = 5) and (minor = 1);
end;

function CheckW2kWXP: Boolean;
var
  Major, Minor : Integer;
begin
  GetWindowsVersion(major, minor);
  Result := (major = 5) and ((minor = 0) or (minor = 1) or (minor = 2));
end;

procedure SetAlphaBlendTransparent;
var
  User32: Cardinal;
  SetLayeredWindowAttributes: function (hwnd: LongInt; crKey: byte; bAlpha: byte; dwFlags: LongInt): LongInt; stdcall;
begin
  User32 := LoadLibrary('USER32');
  if User32 <> 0
  then
    try
     SetLayeredWindowAttributes := GetProcAddress(User32, 'SetLayeredWindowAttributes');
     if @SetLayeredWindowAttributes <> nil
     then
       SetLayeredWindowAttributes(WHandle, 0, Value, LWA_ALPHA);
     finally
        FreeLibrary(User32);
     end;
end;

procedure GetScreenImage(X, Y: Integer; B: TBitMap);
var
  DC: HDC;
begin
  DC := GetDC(0);
  BitBlt(B.Canvas.Handle, 0, 0,
         B.Width, B.Height, DC, X, Y, SrcCopy);
  ReleaseDC(0, DC);
end;

function EqRects(R1, R2: TRect): Boolean;
begin
  Result := (R1.Left = R2.Left) and (R1.Top = R2.Top) and
            (R1.Right = R2.Right) and (R1.Bottom = R2.Bottom);
end;

function NullRect: TRect;
begin
  Result := Rect(0, 0, 0, 0);
end;

function IsNullRect(R: TRect): Boolean;
begin
  Result := (R.Right - R.Left <= 0) or (R.Bottom - R.Top <= 0)
end;

function IsNullPoint(P: TPoint): Boolean;
begin
  Result := (P.X = 0) or (P.Y = 0);
end;

function PointInRect(R: TRect; P: TPoint): Boolean;
begin
  Result := (P.X >= R.Left) and (P.Y >= R.Top) and
            (P.X <= R.Right) and (P.Y <= R.Bottom);
end;

function RectInRect(R1, R2: TRect): Boolean;