bsutils.pas

delphi 皮肤控件

{*******************************************************************}
{                                                                   }
{       Almediadev Visual Component Library                         }
{       BusinessSkinForm                                            }
{       Version 6.07                                                }
{                                                                   }
{       Copyright (c) 2000-2007 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;
  TbsStretchType = (bsstFull, bsstHorz, bsstVert);

{ 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 EqPoints(const Pt1, Pt2: TPoint): 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; AStretchEffect: Boolean; AStretchType: TbsStretchType);

procedure CreateSkinBG(ClRect: TRect; NewClRect: TRect;
   B, SB: TBitMap; R: TRect; AW, AH: Integer; AStretch: Boolean;
   AStretchType: TbsStretchType);

procedure CreateSkinImage(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  B, SB: TBitMap; R: TRect; AW, AH: Integer; ADrawClient: Boolean;
  ALeftStretch, ATopStretch, ARightStretch, ABottomStretch,
  AClientStretch: Boolean; AStretchType: TbsStretchType);

procedure CreateSkinImage2(LtPt, RTPt, LBPt, RBPt: TPoint; ClRect: TRect;
  NewLTPt, NewRTPt, NewLBPt, NewRBPt: TPoint; NewClRect: TRect;
  B, SB: TBitMap; R: TRect; AW, AH: Integer; ADrawClient,
  ALeftStretch, ATopStretch, ARightStretch, ABottomStretch,
  AClientStretch: Boolean; AStretchType: TbsStretchType);

procedure CreateStretchImage(B: TBitMap;  SB: TBitMap; R: TRect; ClRect: TRect;
                             ADrawClient: Boolean);

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

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

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

procedure CreateVSkinImage(TpO, BO: Integer;
  B, SB: TBitMap; R: TRect; AW, AH: Integer; AStretch: Boolean);
  
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;

function CalcTextWidthW(C: TCanvas; Str: WideString): Integer;
function CalcTextHeightW(C: TCanvas; Str: WideString): Integer;
function BSDrawSkinText(ACanvas: TCanvas; AText: WideString; var Bounds: TRect; Flag: cardinal): integer;
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 BSDrawText4(Cnvs: TCanvas; S: String; R: TRect);

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 CorrectTextbyWidthW(C: TCanvas; var S: WideString; W: Integer);

procedure GetParentImage(Control: TControl; Dest: TCanvas);
procedure GetParentImageRect(Control: TControl; Rct: TRect; Dest: TCanvas);

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

function MyGetScrollBarInfo(wnd: Cardinal; idObject: Longint; var psbi: TScrollBarInfo): BOOL;

function IsVistaOs: Boolean;
function Is9XOS: Boolean;

var
  BS_PlatformIsUnicode: Boolean;
  GetScrollBarInfoFunc: function (wnd: Cardinal; idObject: Longint; var psbi: TScrollBarInfo): BOOL; stdcall;

implementation

uses Forms, Consts, bsSkinTabs;

const
  LWA_ALPHA = $2;

type
  TParentControl = class(TWinControl);


function MyGetScrollBarInfo(wnd: Cardinal; idObject: Longint; var psbi: TScrollBarInfo): BOOL;
begin
  if @GetScrollBarInfoFunc <> nil then
    Result := GetScrollBarInfoFunc(wnd, idObject, psbi)
  else
  begin
    { Win95 }
    psbi.rgstate[0] := STATE_SYSTEM_INVISIBLE;
    Result := false;
  end;
end;

procedure GetParentImage(Control: TControl; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left; Y := -Top;
    end;
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
       if (Control.Parent is TForm) and
          (TForm(Control.Parent).FormStyle = fsMDIForm)
       then
         begin
           SendMessage(TForm(Control.Parent).ClientHandle, WM_ERASEBKGND, DC, 0);
         end
      else
      if Control.Parent is TbsSkinTabControl
      then
        begin
          TbsSkinTabControl(Control.Parent).PaintBG(DC);
       end
      else
      with TParentControl(Control.Parent) do begin
        Perform(WM_ERASEBKGND, DC, 0);
        if not (Control.Parent is TForm) then PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;

    for I := 0 to Count - 1 do
    if Control.Parent.Controls[I] <> Control
    then
    begin
      if (Control.Parent.Controls[I] <> nil) and
         (Control.Parent.Controls[I] is TGraphicControl)
      then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SaveIndex := SaveDC(DC);
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end
    end
    else
      Break;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;


procedure GetParentImageRect(Control: TControl; Rct: TRect; Dest: TCanvas);
var
  I, Count, X, Y, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
begin
  if (Control = nil) or (Control.Parent = nil) then Exit;
  Count := Control.Parent.ControlCount;
  DC := Dest.Handle;
  with Control.Parent do ControlState := ControlState + [csPaintCopy];
  try
    with Control do begin
      SelfR := Bounds(Left, Top, Width, Height);
      X := -Left - Rct.Left; Y := -Top - Rct.Top;
    end;
    { Copy parent control image }
    SaveIndex := SaveDC(DC);
    try
      SetViewportOrgEx(DC, X, Y, nil);
      IntersectClipRect(DC, 0, 0, Control.Parent.ClientWidth,
        Control.Parent.ClientHeight);
      if (Control.Parent is TForm) and
         (TForm(Control.Parent).FormStyle = fsMDIForm)
       then
         begin
           SendMessage(TForm(Control.Parent).ClientHandle, WM_ERASEBKGND, DC, 0);
         end
      else
      if Control.Parent is TbsSkinTabControl
      then
        begin
          TbsSkinTabControl(Control.Parent).PaintBG(DC);
       end
      else
      with TParentControl(Control.Parent) do begin
        Perform(WM_ERASEBKGND, DC, 0);
        if not (Control.Parent is TForm) then PaintWindow(DC);
      end;
    finally
      RestoreDC(DC, SaveIndex);
    end;
    
    for I := 0 to Count - 1 do
    if Control.Parent.Controls[I] <> Control
    then
    begin
      if (Control.Parent.Controls[I] <> nil) and
         (Control.Parent.Controls[I] is TGraphicControl)
      then
      begin
        with TGraphicControl(Control.Parent.Controls[I]) do begin
          CtlR := Bounds(Left, Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then begin
            ControlState := ControlState + [csPaintCopy];
            SaveIndex := SaveDC(DC);
            try
              SaveIndex := SaveDC(DC);
              SetViewportOrgEx(DC, Left + X, Top + Y, nil);
              IntersectClipRect(DC, 0, 0, Width, Height);
              Perform(WM_PAINT, DC, 0);
            finally
              RestoreDC(DC, SaveIndex);
              ControlState := ControlState - [csPaintCopy];
            end;
          end;
        end;
      end
    end
    else
      Break;
  finally
    with Control.Parent do ControlState := ControlState - [csPaintCopy];
  end;
end;


function CalcTextWidthW(C: TCanvas; Str: WideString): Integer;
var
  R: TRect;
begin
  R := Rect(0, 0, 0, 0);
  BSDrawSkinText(C, Str, R, DT_CALCRECT);
  Result := RectWidth(R);
end;

function CalcTextHeightW(C: TCanvas; Str: WideString): Integer;
var
  R: TRect;
begin
  R := Rect(0, 0, 0, 0);
  BSDrawSkinText(C, Str, R, DT_CALCRECT);
  Result := RectHeight(R);
end;

procedure CorrectTextbyWidthW(C: TCanvas; var S: WideString; W: Integer);