tsimagelist.pas

企业进销存管理系统

{*******************************************************}
{                                                       }
{       Top Support Visual Components                   }
{       TopGrid component TtsImageList                  }
{                                                       }
{       Copyright (c) 1997 - 1999, Top Support          }
{                                                       }
{*******************************************************}

unit TSImageList;

{$INCLUDE TSCmpVer}

interface

uses
  Windows, SysUtils, Classes, Dialogs, Graphics
  {$IFDEF TSVER_V3}, ComObj, ActiveX {$ENDIF}
  {$IFDEF TSVER_V6}, Variants {$ENDIF};

type
    TtsImage = class;
    TtsImageItem = class;
    TtsImageCollection = class;
    TtsImageList = class;
    TtsImageLink = class;

    TtsImageListOnChangeEvent = procedure(Sender: TObject; Image: TtsImage) of object;

    TtsImageListComponent = class(TComponent)
    protected
        procedure AddLink(ImageLink: TtsImageLink); virtual; abstract;
        procedure RemoveLink(ImageLink: TtsImageLink); virtual; abstract;
        function  GetImage(Index: Variant): TtsImageItem; virtual; abstract;
        procedure SetImage(Index: Variant; Value: TtsImageItem); virtual; abstract;
        function  GetGUID: string; virtual; abstract;
        function  GetImageCollection: TCollection; virtual; abstract;

    public
        function  IdIndex(Value: Integer): Integer; virtual; abstract;
        function  IndexExists(Index: Variant): Boolean; virtual; abstract;
        function  NameIndex(Value: string): Integer; virtual; abstract;
        function  NextIndex(Value: Variant): Variant; virtual; abstract;
        function  PrevIndex(Value: Variant): Variant; virtual; abstract;

        property ImageCollection: TCollection read GetImageCollection;
        property GUID: string read GetGUID;
        property Image[Index: Variant]: TtsImageItem read GetImage write SetImage;
    end;

    TtsImageList = class(TtsImageListComponent)
    protected
        FGUID: String;
        FImageCollection: TtsImageCollection;
        FLinks: TList;
        FOnChange: TtsImageListOnChangeEvent;

        procedure AddLink(ImageLink: TtsImageLink); override;
        procedure Changed(Image: TtsImage); virtual;
        procedure DefineProperties(Filer: TFiler); override;
        procedure ReadGUID(Reader: TReader);
        procedure ReadSetNames(Reader: TReader);
        procedure RemoveLink(ImageLink: TtsImageLink); override;
        procedure RemoveLinks;
        procedure SetImages(Value: TtsImageCollection);
        function  GetImage(Index: Variant): TtsImageItem; override;
        procedure SetImage(Index: Variant; Value: TtsImageItem); override;
        function  GetGUID: string; override;
        function  GetImageCollection: TCollection; override;
        procedure WriteGUID(Writer: TWriter);
        procedure WriteSetNames(Writer: TWriter);

    public
        constructor Create(AOwner: TComponent); override;
        destructor Destroy; override;

        procedure Assign(Source: TPersistent); override;
        procedure Clear;
        function  IdIndex(Value: Integer): Integer; override;
        function  IndexExists(Index: Variant): Boolean; override;
        function  NameIndex(Value: string): Integer; override;
        function  NextIndex(Value: Variant): Variant; override;
        function  PrevIndex(Value: Variant): Variant; override;

        property GUID: string read GetGUID;
    published
        property Images: TtsImageCollection read FImageCollection write SetImages;
        property OnChange: TtsImageListOnChangeEvent read FOnChange write FOnChange;
    end;

    {$IFNDEF TSVER_V3}
    TTransparentMode = (tmAuto, tmFixed);
    {$ENDIF}

    TtsImageItem = class(TCollectionItem)
    protected
        function  GetBitmap: TBitmap; virtual; abstract;
        procedure SetBitmap(Value: TBitmap); virtual; abstract;
        function  GetName: string; virtual; abstract;
        procedure SetRefName(Value: string); virtual; abstract;
        function  GetSetName: string; virtual; abstract;
        procedure SetSetName(Value: string); virtual; abstract;
        function  GetTransparent: Boolean; virtual; abstract;
        procedure SetTransparent(Value: Boolean); virtual; abstract;
        function  GetTransparentColor: TColor; virtual; abstract;
        procedure SetTransparentColor(Value: TColor); virtual; abstract;
        function  GetTransparentMode: TTransparentMode; virtual; abstract;
        procedure SetTransparentMode(Value: TTransparentMode); virtual; abstract;
        function  GetID: Integer; virtual; abstract;

    public
        property ID: Integer read GetID;

    published
        property Bitmap: TBitmap read GetBitmap write SetBitmap;
        property Name: string read GetName write SetRefName;
        property SetName: string read GetSetName write SetSetName;
        property Transparent: Boolean read GetTransparent write SetTransparent stored True;
        property TransparentColor: TColor read GetTransparentColor write SetTransparentColor stored True;
        property TransparentMode: TTransparentMode read GetTransparentMode write SetTransparentMode stored True;
    end;

    TtsImage = class(TtsImageItem)
    protected
        FBitmap: TBitmap;
        //transparency info of bitmap is also stored in seperate fields for compatibility with Delphi 2.0 (no transparency info in bitmap)
        //and because Delphi doesn't save property values of bitmap except for the image itself
        FTransparent: Boolean;
        FTransparentColor: TColor;
        FTransparentMode: TTransparentMode;
        FName: string;
        FSetName: string;
        FUpdateCount: Integer;
        FID: Integer;

        procedure BeginUpdate;
        procedure Changed; virtual;
        procedure DefineProperties(Filer: TFiler); override;
        procedure EndUpdate;
        procedure FBitmapChange(Sender: TObject);
        procedure ReadID(Reader: TReader);
        procedure WriteID(Writer: TWriter);

        function  GetBitmap: TBitmap; override;
        function  GetName: string; override;
        function  GetSetName: string; override;
        function  GetTransparent: Boolean; override;
        function  GetTransparentColor: TColor; override;
        function  GetTransparentMode: TTransparentMode; override;
        function  GetID: Integer; override;
        procedure SetBitmap(Value: TBitmap); override;
        procedure SetRefName(Value: string); override;
        procedure SetSetName(Value: string); override;
        procedure SetTransparent(Value: Boolean); override;
        procedure SetTransparentColor(Value: TColor); override;
        procedure SetTransparentMode(Value: TTransparentMode); override;

    public
        constructor Create(Collection: TCollection); override;
        destructor Destroy; override;
        procedure Assign(Source: TPersistent); override;
    end;

    TtsImageClass = class of TtsImage;

    TtsImageCollection = class(TCollection)
    protected
        FImageList: TtsImageList;
        FOnChange: TNotifyEvent;
        FSetNames: TStringList;
        Ftest: Integer;

        procedure SetTsImage(Index: Variant; Value: TtsImage);
        procedure Update(Item: TCollectionItem); override;
        function  GetOwner: TPersistent; {$IFDEF TSVER_V3} override; {$ENDIF}
        function  GetTsImage(Index: Variant): TtsImage;
        function  GetNextIndex(Index: Variant; Direction: Integer): Variant;

        property SetNames: TStringList read FSetNames write FSetNames;
    public
        constructor Create(ImageList: TtsImageList; ImageClass: TtsImageClass);
        destructor Destroy; override;

        procedure Assign(Source: TPersistent); override;
        function Add: TtsImage;
        function IdIndex(Value: Integer): Integer;
        function IndexExists(Index: Variant): Boolean;
        function Insert(Index: Integer): TtsImage;
        function NameIndex(Value: string): Integer;
        function NextIndex(Index: Variant): Variant;
        function PrevIndex(Index: Variant): Variant;

        property test: Integer read Ftest write Ftest stored True;
        property ImageList: TtsImageList read FImageList;
        property Items[Index: Variant]: TtsImage read GetTsImage write SetTsImage; default;
        property OnChange: TNotifyEvent read FOnChange write FOnChange;
    end;

    TtsImageLink = class(TPersistent)
    protected
        FImageList: TtsImageListComponent;

        procedure SetImageList(Value: TtsImageListComponent);
        procedure ImageChanged(Image: TtsImageItem); virtual;
        procedure ImageListDeleted; virtual;
        function  GetTsImage(Name: Variant): TtsImageItem;

    public
        constructor Create;
        destructor Destroy; override;

        property Image[Name: Variant]: TtsImageItem read GetTsImage;
        property ImageList: TtsImageListComponent read FImageList write SetImageList;
    end;

procedure tsStretchDraw(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap; TransparentColor: TColor; CenterImage: Boolean; StretchToFit: Boolean; ShrinkToFit: Boolean; MaintainAspect: Boolean);

{$IFNDEF TSVER_V3}
type
    TGUID = record
                D1: Integer;
                D2: Word;
                D3: Word;
                D4: array[0..7] of Byte;
            end;

function CoCreateGuid(var Guid: TGUID): HResult; stdcall;
function StringFromCLSID(const clsid: TGUID; var psz: PWideChar): HResult; stdcall;
procedure CoTaskMemFree(pv: Pointer); stdcall;
{$ENDIF}

implementation

{$R *.dcr}

const
    VersionNumber = '2.0';

{$IFNDEF TSVER_V3}
function CoCreateGuid; external 'ole32.dll' name 'CoCreateGuid';
function StringFromCLSID; external 'ole32.dll' name 'StringFromCLSID';
procedure CoTaskMemFree; external 'ole32.dll' name 'CoTaskMemFree';
{$ENDIF}

procedure tsStretchDraw(Canvas: TCanvas; DestRect: TRect; Bitmap: TBitmap; TransparentColor: TColor; CenterImage: Boolean; StretchToFit: Boolean; ShrinkToFit: Boolean; MaintainAspect: Boolean);
var
    OrgDestRect, SrcRect : TRect;
    DestRatio, SrcRatio: Single;
    DestHeight, DestWidth : Integer;
    SrcHeight, SrcWidth : Integer;
    NewDestHeight, NewDestWidth : Integer;
begin
    OrgDestRect := DestRect;

    if Bitmap.Empty then
        Canvas.FillRect(DestRect)
    else
    begin
        DestHeight := DestRect.Bottom - DestRect.Top;
        DestWidth := DestRect.Right - DestRect.Left;
        DestRatio := DestWidth / DestHeight;

        SrcRect := Rect(0, 0, Bitmap.Width, Bitmap.Height);
        SrcHeight := SrcRect.Bottom - SrcRect.Top;
        SrcWidth := SrcRect.Right - SrcRect.Left;
        SrcRatio := (SrcRect.Right - SrcRect.Left) / (SrcRect.Bottom - SrcRect.Top);

        if MaintainAspect then
        begin
            if not ShrinkToFit then
            begin
                if DestWidth < SrcWidth then
                begin
                    if CenterImage then SrcRect.Left := (SrcRect.Right - DestWidth) div 2;
                    SrcRect.Right := SrcRect.Left + DestWidth;
                end;

                if DestHeight < SrcHeight then
                begin
                    if CenterImage then SrcRect.Top := (SrcRect.Bottom - DestHeight) div 2;
                    SrcRect.Bottom := SrcRect.Top + DestHeight;
                end;

                SrcHeight := SrcRect.Bottom - SrcRect.Top;
                SrcWidth := SrcRect.Right - SrcRect.Left;
                SrcRatio := (SrcRect.Right - SrcRect.Left) / (SrcRect.Bottom - SrcRect.Top);
            end;

            if not StretchToFit then
            begin
                if SrcWidth < DestWidth then
                begin
                    if CenterImage then DestRect.Left := DestRect.Left + (DestWidth - SrcWidth) div 2;
                    DestRect.Right := DestRect.Left + SrcWidth;
                end;

                if SrcHeight < DestHeight then
                begin
                    if CenterImage then DestRect.Top := DestRect.Top + (DestHeight - SrcHeight) div 2;
                    DestRect.Bottom := DestRect.Top + SrcHeight;
                end;

                DestHeight := DestRect.Bottom - DestRect.Top;
                DestWidth := DestRect.Right - DestRect.Left;
                DestRatio := DestWidth / DestHeight;
            end;

            //do the actual scaling
            if SrcRatio > DestRatio then
            begin
                NewDestHeight := Round(DestWidth / SrcRatio);
                if CenterImage then DestRect.Top := DestRect.Top + (DestHeight - NewDestHeight) div 2;
                DestRect.Bottom := DestRect.Top + NewDestHeight;
            end
            else
            begin
                NewDestWidth := Round(DestHeight * SrcRatio);
                if CenterImage then DestRect.Left := DestRect.Left + (DestWidth - NewDestWidth) div 2;
                DestRect.Right := DestRect.Left + NewDestWidth;
            end
        end
        else
        begin
            //don't have to maintain aspect ratio
            //scale horizontal and vertical seperately
            if SrcWidth < DestWidth then
            begin
                if not StretchToFit then
                begin
                    if CenterImage then DestRect.Left := DestRect.Left + Round((DestWidth - SrcWidth) / 2);
                    DestRect.Right := DestRect.Left + SrcWidth;
                end;
            end
            else if not ShrinkToFit then
            begin
                if CenterImage then
                begin
                    SrcRect.Left := Round((SrcWidth - DestWidth)/2);
                    SrcRect.Right := SrcRect.Left + DestWidth;
                end
                else
                    SrcRect.Right := DestWidth;
            end;

            if SrcHeight < DestHeight then
            begin
                if not StretchToFit then
                begin
                    if CenterImage then DestRect.Top := DestRect.Top + Round((DestHeight - SrcHeight) / 2);
                    DestRect.Bottom := DestRect.Top + SrcHeight;
                end;
            end
            else
            begin
                if not ShrinkToFit then
                begin
                    if CenterImage then
                    begin
                        SrcRect.Top := Round((SrcHeight - DestHeight)/2);
                        SrcRect.Bottom := SrcRect.Top + DestHeight;
                    end
                    else
                        SrcRect.Bottom := DestHeight;
                end;
            end;
        end;

        //draw the scaled image
        Canvas.FillRect(OrgDestRect);

        if TransparentColor <> clNone then
            Canvas.BrushCopy(DestRect, Bitmap, SrcRect, TransparentColor)
        else
            //use Copyrect and not Brushcopy when bitmap is not transparent, it's much faster
            Canvas.CopyRect(DestRect, Bitmap.Canvas, SrcRect);
    end;
end;


procedure SplitRefSetName(Value: string; var SetName: string; var RefName: string);
//syntax of 'Value' : [Setname.]<Name>
var
    I: Integer;
begin
    Value := Trim(Value);

    I := Pos('.', Value);
    if I > 0 then
    begin
        SetName := Trim(Copy(Value, 1, I - 1));
        RefName := Trim(Copy(Value, I + 1, Length(Value)));
    end