sputils.pas

灰鸽子VIP1.2经典源代码

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

unit SPUtils;

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

interface

{$R-}

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

const
  maxi = 10000;
  //

  SP_XP_BTNFRAMECOLOR = 8388608;
  SP_XP_BTNACTIVECOLOR = 13811126;
  SP_XP_BTNDOWNCOLOR = 11899781;
  
type

{ TFBitmap }

  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;

  TFBitmap = 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 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 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 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);

function IsJpegFile(AFileName: String): Boolean;
procedure LoadFromJpegFile(SB: TBitMap; AFileName: String);
procedure LoadFromJpegStream(SB: TBitMap; AStream: TStream);
procedure LoadFromJPegImage(SB: TBitMap; JI: TJpegImage);

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);
procedure GetParentImage(Control: TControl; Dest: TCanvas);
procedure GetParentImage2(Control: TControl; Dest: TCanvas);
function PointInRect(R: TRect; P: TPoint): Boolean;

procedure SPDrawText(Cnvs: TCanvas; S: String; R: TRect);
procedure SPDrawText2(Cnvs: TCanvas; S: String; R: TRect);
procedure SPDrawText3(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 Max(A, B: Longint): Longint;
function Min(A, B: Longint): Longint;

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

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 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;


procedure GetControls(X, Y, W, H: Integer;
                      Control: TCustomControl; Dest: TCanvas);
var
  I, Count, SaveIndex: Integer;
  DC: HDC;
  R, SelfR, CtlR: TRect;
  Ctrl: TControl;
begin
  Count := Control.ControlCount;
  DC := Dest.Handle;
  SelfR := Bounds(0, 0, W, H);
  // Copy images of controls
  for I := 0 to Count - 1 do
  begin
    Ctrl := Control.Controls[I];
    if (Ctrl <> nil) and (Ctrl is TCustomControl)
    then
      begin
        with Ctrl do
        begin
          CtlR := Bounds(X + Left, Y + Top, Width, Height);
          if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
          begin
            SaveIndex := SaveDC(DC);
            SetViewportOrgEx(DC, Left + X, Top + Y, nil);
            IntersectClipRect(DC, 0, 0, Width, Height);
            Perform(WM_PAINT, DC, 0);
            RestoreDC(DC, SaveIndex);
            if TCustomControl(Ctrl).ControlCount <> 0
            then
              GetControls(Left + X, Top + Y, W, H,
              TCustomControl(Ctrl), Dest);
          end;
       end;
    end;
  end;
end;

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).Perform(WM_ERASEBKGND, DC, 0);
      TParentControl(Control.Parent).Perform(WM_PAINT, DC, 0);
      RestoreDC(DC, SaveIndex);
    end;

  // Copy images of controls
  for I := 0 to Count - 1 do
  begin
    Ctrl := Control.Parent.Controls[I];
    if Ctrl = Control then Break;
    if (Ctrl <> nil) and
       ((Ctrl is TGraphicControl) or (Ctrl is TCustomControl))
    then
      with Ctrl do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_PAINT, DC, 0);
          RestoreDC(DC, SaveIndex);
          if Ctrl is TCustomControl
          then
            GetControls(Left + X, Top + Y,
              Control.Width, Control.Height,
              TCustomControl(Ctrl), Dest);
        end;
     end;
  end;
end;

procedure GetParentImage2(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;
  // Copy images of controls
  for I := 0 to Count - 1 do
  begin
    Ctrl := Control.Parent.Controls[I];
    if Ctrl = Control then Break;
    if (Ctrl <> nil) and (Ctrl is TGraphicControl)
    then
      with Ctrl do
      begin
        CtlR := Bounds(Left, Top, Width, Height);
        if Bool(IntersectRect(R, SelfR, CtlR)) and Visible then
        begin
          SaveIndex := SaveDC(DC);
          SetViewportOrgEx(DC, Left + X, Top + Y, nil);
          IntersectClipRect(DC, 0, 0, Width, Height);
          Perform(WM_PAINT, DC, 0);
          RestoreDC(DC, SaveIndex);
        end;
     end;
  end;
end;

procedure SPDrawText(Cnvs: TCanvas; S: String; R: TRect);
begin
  DrawText(Cnvs.Handle, PChar(S), Length(S), R,
    DT_VCENTER or DT_SINGLELINE or DT_LEFT);
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;


procedure SPDrawText2(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 SPDrawText3(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