tsimagelist.pas

来自「企业进销存管理系统」· PAS 代码 · 共 1,174 行 · 第 1/3 页

    else
    begin
        SetName := '';
        RefName := Trim(Value);
    end;
end;

{TtsImage}

procedure TtsImage.BeginUpdate;
begin
    Inc(FUpdateCount);
end;

procedure TtsImage.EndUpdate;
begin
    Dec(FUpdateCount);
end;

procedure TtsImage.Changed;
begin
    if (FUpdateCount = 0) and (Collection <> nil) then
        inherited Changed(False);
end;

procedure TtsImage.FBitmapChange(Sender: TObject);
begin
    {$IFDEF TSVER_V3}
    FTransparentMode := FBitmap.TransparentMode;
    FTransparentColor := FBitmap.TransparentColor;
    FTransparent := FBitmap.Transparent;
    {$ENDIF}
    Changed;
end;

constructor TtsImage.Create(Collection: TCollection);
begin
    FUpdateCount := 0;
    FID := 0;

    BeginUpdate;
    try
        inherited;

        FBitmap := TBitmap.Create;
        TransparentColor := clWhite;
        TransparentMode := tmAuto;

        Transparent := False;
        FName := '';
        FSetName := '';

        FBitmap.OnChange := FBitmapChange;
    finally
        EndUpdate;
    end;
end;

destructor TtsImage.Destroy;
var
    ImageCollection: TtsImageCollection;
begin
    ImageCollection := TtsImageCollection(Collection);

    FBitmap.Free;
    inherited;

    if Assigned(ImageCollection) then
        ImageCollection.Changed;
end;

function TtsImage.GetBitmap: TBitmap;
begin
    Result := FBitmap;
end;

function TtsImage.GetName: string;
begin
    Result := FName;
end;

function TtsImage.GetSetName: string;
begin
    Result := FSetName;
end;

function TtsImage.GetTransparent: Boolean;
begin
    Result := FTransparent;
end;

function TtsImage.GetTransparentColor: TColor;
begin
    if TransparentMode = tmAuto
        then Result := Bitmap.Canvas.Pixels[0, Bitmap.Height - 1]
        else Result := FTransparentColor;
end;

function TtsImage.GetTransparentMode: TTransparentMode;
begin
    Result := FTransparentMode;
end;

function TtsImage.GetID: Integer;
begin
    Result := FID;
end;

procedure TtsImage.SetBitmap(Value: TBitmap);
begin
    if Value <> nil then
    begin
        if not(Value.Empty) then
        begin
            BeginUpdate;
            try
                FBitmap.Free;
                FBitmap := TBitmap.Create;
                FBitmap.OnChange := FBitmapChange;
                FBitmap.Assign(Value);
            finally
                EndUpdate;
            end;
            Changed;
        end;
    end;
end;

procedure TtsImage.SetRefName(Value: string);
//syntax of Value : [Setname.]<Name>
var
    I: Integer;
    Found: Boolean;
    RefName: string;
    SetName_: string;
begin
    if Assigned(Collection) then
    begin
        if Assigned(TtsImageCollection(Collection).ImageList) then
        begin
            if csReading in TtsImageCollection(Collection).ImageList.ComponentState then
            begin
                FName := Value;
                Exit;
            end;
        end;
    end;

    SplitRefSetName(Value, SetName_, RefName);
    if SetName_='' then SetName_ := FSetName;

    if (Trim(RefName) <> Trim(FName)) or (Trim(SetName_) <> Trim(FSetName)) then
    begin
        Found := False;
        if Assigned(Collection) then
        begin
            if (Collection.Count > 1) then
            begin
                for I := 0 to Collection.Count - 1 do
                    if ( Trim(LowerCase(TtsImage(Collection.Items[I]).FName)) = Trim(LowerCase(RefName)) ) and
                       ( Trim(LowerCase(TtsImage(Collection.Items[I]).FSetName)) = Trim(LowerCase(SetName_)) ) and
                       ( TtsImage(Collection.Items[I]).ID <> ID ) then
                    begin
                        Found := True;
                        Break;
                    end;
            end;
        end;

        if Found then
        begin
            if SetName_='' then
                raise EListError.CreateFmt('Name ''%s'' already exists in main set.', [RefName])
            else
                raise EListError.CreateFmt('Name ''%s'' already exists in set ''%s''.', [RefName, SetName_])
        end
        else
        begin
            FName := RefName;
            FSetName := SetName_;
            if Assigned(Collection) then
            begin
                if (SetName_ <> '') and (TtsImageCollection(Collection).FSetNames.IndexOf(SetName_) = -1) then
                    TtsImageCollection(Collection).FSetNames.Add(SetName_);
            end;
            Changed;
        end;
    end;
end;

procedure TtsImage.SetSetName(Value: string);
var
    I: Integer;
    Found: Boolean;
begin
    if Assigned(Collection) then
    begin
        if Assigned(TtsImageCollection(Collection).ImageList) then
        begin
            if csReading in TtsImageCollection(Collection).ImageList.ComponentState then
            begin
                FSetName := Value;
                if (Value <> '') and (TtsImageCollection(Collection).FSetNames.IndexOf(Value) = -1) then
                    TtsImageCollection(Collection).FSetNames.Add(Value);
                Exit;
            end;
        end;
    end;

    Value := Trim(Value);
    if UpperCase(Value) <> UpperCase(FSetName) then
    begin
        Found := False;
        if Assigned(Collection) then
        begin
            if (Collection.Count > 1) then
            begin
                for I := 0 to Collection.Count - 1 do
                begin
                    if (Trim(LowerCase(TtsImage(Collection.Items[I]).FName)) = Trim(LowerCase(FName))) and
                       (Trim(LowerCase(TtsImage(Collection.Items[I]).FSetName)) = Trim(LowerCase(Value))) then
                    begin
                        Found := True;
                        Break;
                    end;
                end;
            end;
        end;

        if Found then
        begin
            if Value = '' then
                raise EListError.CreateFmt('Name ''%s'' already exists in main set.', [FName, Value])
            else
                raise EListError.CreateFmt('Name ''%s'' already exists in set ''%s''.', [FName, Value])
        end
        else
        begin
            FSetName := Value;
            if Assigned(Collection) then
                if (Value <> '') and (TtsImageCollection(Collection).FSetNames.IndexOf(Value) = -1) then
                    TtsImageCollection(Collection).FSetNames.Add(Value);
            Changed;
        end;
    end;
end;

procedure TtsImage.Assign(Source: TPersistent);
begin
    if Source is TtsImage and (Assigned(Source)) then
    begin
        BeginUpdate;

        try
            FBitmap.Free;
            FBitmap := TBitmap.Create;
            if TtsImage(Source).FBitmap <> nil then
               FBitmap.Assign(TtsImage(Source).FBitmap);

            if Assigned(Collection) then
                if (TtsImage(Source).FSetName <> '') and (TtsImageCollection(Collection).FSetNames.IndexOf(TtsImage(Source).FSetName) = -1) then
                    TtsImageCollection(Collection).FSetNames.Add(TtsImage(Source).FSetName);

            FSetName := TtsImage(Source).FSetName;
            FName := TtsImage(Source).FName;
            FID := TtsImage(Source).FID;
            Transparent := TtsImage(Source).FTransparent;
            TransparentColor := TtsImage(Source).FTransparentColor;
            TransparentMode := TtsImage(Source).FTransparentMode;
        finally
            EndUpdate;
        end;
        Changed;
    end;
end;

procedure TtsImage.SetTransparent(Value: Boolean);
begin
    FTransparent := Value;
    {$IFDEF TSVER_V3}
    FBitmap.Transparent := Value;
    {$ENDIF}
    Changed;
end;

procedure TtsImage.SetTransparentMode(Value: TTransparentMode);
begin
    FTransparentMode := Value;
    {$IFDEF TSVER_V3}
    FBitmap.TransparentMode := Value;
    FTransparentColor := FBitmap.TransparentColor;
    {$ENDIF}
    Changed;
end;

procedure TtsImage.SetTransparentColor(Value: TColor);
begin
    {$IFDEF TSVER_V3}
    FBitmap.TransparentColor := Value;
    {$ENDIF}
    FTransparentColor := Value;
    Changed;
end;

procedure TtsImage.DefineProperties(Filer: TFiler);
begin
    inherited;
    Filer.DefineProperty('ID', ReadID, WriteID, True);
end;

procedure TtsImage.WriteID(Writer: TWriter);
begin
    Writer.WriteInteger(FID);
end;

procedure TtsImage.ReadID(Reader: TReader);
begin
    FID := Reader.ReadInteger;
end;

{TtsImageList}

constructor TtsImageList.Create(AOwner: TComponent);
var
    Temp: TGUID;
    {$IFNDEF TSVER_V3}
    P: PWideChar;
    {$ENDIF}
begin
    inherited Create(Aowner);
    FImageCollection := TtsImageCollection.Create(Self, TtsImage);
    FLinks := TList.Create;

{$IFDEF TSVER_V3}
    CoCreateGuid(Temp);
    FGUID := GUIDToString(Temp);
{$ELSE}
    CoCreateGuid(Temp);
    StringFromCLSID(Temp, P);
    FGUID := WideCharToString(P);
    CoTaskMemFree(P);
{$ENDIF}
end;

destructor TtsImageList.Destroy;
begin
    RemoveLinks;
    FImageCollection.Free;
    FLinks.Free;
    inherited;
end;

procedure TtsImageList.Assign(Source: TPersistent);
begin
    if Source is TtsImageList then
    begin
        FImageCollection.Assign(TtsImageList(Source).FImageCollection);
        FImageCollection.FImageList := Self;
    end;
end;

procedure TtsImageList.Clear;
begin
    RemoveLinks;
    FImageCollection.Clear;
    FImageCollection.FSetNames.Clear;
    FLinks.Clear;
end;

function TtsImageList.IdIndex(Value: Integer): Integer;
begin
    Result := Images.IdIndex(Value);
end;

function TtsImageList.IndexExists(Index: Variant): Boolean;
begin
    Result := Images.IndexExists(Index);
end;

function TtsImageList.NameIndex(Value: string): Integer;
begin
    Result := Images.NameIndex(Value);
end;

function TtsImageList.NextIndex(Value: Variant): Variant;
begin
    Result := Images.NextIndex(Value);
end;

function TtsImageList.PrevIndex(Value: Variant): Variant;
begin
    Result := Images.PrevIndex(Value);