tsimagelist.pas

企业进销存管理系统

end;

procedure TtsImageList.AddLink(ImageLink: TtsImageLink);
begin
    FLinks.Add(ImageLink);
    ImageLink.FImageList := Self;
end;

procedure TtsImageList.RemoveLink(ImageLink: TtsImageLink);
begin
    ImageLink.FImageList := nil;
    FLinks.Remove(ImageLink);
end;

procedure TtsImageList.RemoveLinks;
var
    I: Integer;
    Link: TtsImageLink;
begin
    for I := FLinks.Count - 1 downto 0 do
    begin
        Link := TtsImageLink(FLinks.Items[I]);
        RemoveLink(Link);
        Link.ImageListDeleted;
    end;
end;

procedure TtsImageList.SetImages(Value: TtsImageCollection);
begin
    FImageCollection.Assign(Value);
end;

function TtsImageList.GetImage(Index: Variant): TtsImageItem;
begin
  Result := Images[Index];
end;

procedure TtsImageList.SetImage(Index: Variant; Value: TtsImageItem);
begin
    if Value is TtsImage then Images[Index] := TtsImage(Value);
end;

function TtsImageList.GetGUID: string;
begin
    Result := FGUID;
end;

function TtsImageList.GetImageCollection: TCollection;
begin
    Result := Images;
end;

procedure TtsImageList.Changed(Image: TtsImage);
var
    I: Integer;
begin
    if Assigned(FOnChange) then FOnChange(Self, Image);
    for I := 0 to FLinks.Count - 1 do
        TtsImageLink(FLinks.Items[I]).ImageChanged(Image);
end;

procedure TtsImageList.DefineProperties(Filer: TFiler);
begin
    inherited;
    Filer.DefineProperty('GUID', ReadGUID, WriteGUID, True);
    Filer.DefineProperty('SetNames', ReadSetNames, WriteSetNames, (Assigned(Images)));
end;

procedure TtsImageList.WriteGUID(Writer: TWriter);
begin
    Writer.WriteString(FGUID);
end;

procedure TtsImageList.ReadGUID(Reader: TReader);
begin
    FGUID := Reader.ReadString;
end;

procedure TtsImageList.WriteSetNames(Writer: TWriter);
begin
    Writer.WriteString(Images.SetNames.CommaText);
end;

procedure TtsImageList.ReadSetNames(Reader: TReader);
begin
    Images.SetNames.CommaText := Reader.ReadString;
end;

{TtsImageCollection}

function TtsImageCollection.NameIndex(Value: string): Integer;
//syntax of 'Value' : [Setname.]<Name>
var
    I: Integer;
    SetName: string;
    RefName: string;
begin
    Result := -1;
    if Count > 0 then
    begin
        SplitRefSetName(Value, SetName, RefName);
        for I := 0 to Count - 1 do
        begin
            if (Trim(LowerCase(Items[I].FName)) = Trim(LowerCase(RefName))) and
               (Trim(LowerCase(Items[I].FSetName)) = Trim(LowerCase(SetName))) then
            begin
                Result := I;
                Break;
            end;
        end;
    end;
end;

function TtsImageCollection.GetNextIndex(Index: Variant; Direction: Integer): Variant;
var
    I: Integer;
    Found: Boolean;
begin
    Result := Unassigned;
    if Count = 0 then Exit;

    if (VarType(Index) = varString) then
    begin
        if (Index = '') then
        begin
            if Direction > 0
                then Result := 0
                else Result := Count-1;
        end
        else
        begin
            Index := NameIndex(Index);
            if Index >= 0 then
            begin
                I := Index;
                Found := False;
                while not Found  do
                begin
                    Inc(I, Direction);
                    if I >= Count then
                        I := 0
                    else if I < 0 then
                        I := Count - 1;
                    if I = Index then Break;
                    if Items[Index].SetName = Items[I].SetName then Found := True;
                end;
                Result := I;
            end;
        end;
    end
    else if (VarType(Index) = varInteger) {$IFDEF TSVER_V6} or
            (VarType(Index) = varLongWord) {$ENDIF} then
    begin
        Inc(Index, Direction);
        if Index >= Count then
            Index := 0
        else if Index < 0 then
            Index := Count - 1;
        Result := Index;
    end;
end;

function TtsImageCollection.NextIndex(Index: Variant): Variant;
begin
    Result := GetNextIndex(Index, 1);
end;

function TtsImageCollection.PrevIndex(Index: Variant): Variant;
begin
    Result := GetNextIndex(Index, -1);
end;

function TtsImageCollection.IndexExists(Index: Variant): Boolean;
begin
  if (VarType(Index) = varEmpty) or
     (VarType(Index) = varNull) then
     Result := False
  else
  begin
    case VarType(Index) of
        varString:
            begin
                if NameIndex(Index) = -1 then
                    Result := False
                else
                    Result := True;
            end;
    else
            begin
                if (Index < 0) Or (Index >= Count) then
                    Result := False
                else
                    Result := True;
            end;
    end;
  end;
end;

function TtsImageCollection.IdIndex(Value: Integer): Integer;
var
    I: Integer;
begin
    Result := -1;
    if Count > 0 then
    begin
        for I := 0 to Count - 1 do
        begin
            if Value = Items[I].FId then
            begin
                Result := I;
                Break;
            end;
        end;
    end;
end;

constructor TtsImageCollection.Create(ImageList: TtsImageList; ImageClass: TtsImageClass);
begin
    inherited Create(ImageClass);
    FImageList := ImageList;
    FSetNames := TStringList.Create;
end;

destructor TtsImageCollection.Destroy;
begin
    inherited;
    FSetNames.Free;
end;

procedure TtsImageCollection.Assign(Source: TPersistent);
begin
    inherited;
    if Source is TtsImageCollection then
        FSetNames.Assign(TtsImageCollection(Source).SetNames);
end;

function TtsImageCollection.Add: TtsImage;
var
    MaxID, FreeIndex, Index, Code, I, J: Integer;
    Found: Boolean;
begin
    MaxID := 0;
    FreeIndex := 1;

    if Count > 0 then
    begin
        for I := 0 to Count - 1 do
            if Items[I].ID > MaxID then MaxID := Items[I].ID;

        for I := 0 to Count - 1 do
        begin
            Found := True;
            for J := 0 to Count - 1 do
            begin
                if Copy(LowerCase(Items[J].Name), 1, 5) = 'image' then
                begin
                    Val(Copy(Items[J].Name, 6, Length(Items[J].Name)), Index, Code);
                    if (Code = 0) and (Index = FreeIndex) then
                    begin
                        Found := False;
                        Break;
                    end;
                end;
            end;

            if Found then Break;
            Inc(FreeIndex, 1);
        end;
    end;

    Result := TtsImage(inherited Add);
    Result.FID := MaxID + 1;
    Result.Name := 'Image' + IntToStr(FreeIndex);
end;

procedure TtsImageCollection.Update(Item: TCollectionItem);
begin
    if Assigned(FOnChange) then FOnChange(self);
    if Assigned(FImageList) then FImageList.Changed(TtsImage(Item));
end;

function TtsImageCollection.Insert(Index: Integer): TtsImage;
begin
{$IFDEF TSVER_V4}
    Result := TtsImage(inherited Insert(Index));
{$ELSE}
    //not available for Delphi 2/3
    Result := nil;
{$ENDIF}
end;

function TtsImageCollection.GetTsImage(Index: Variant): TtsImage;
var
    I: Integer;
begin
    Result := nil;
    if Count > 0 then
    begin
        case VarType(Index) of
            varString:
                begin
                    I := NameIndex(Index);
                    if I < 0 then
                        raise EListError.CreateFmt('Index ''%s'' not found in imagelist.', [Index])
                    else
                        Result := TtsImage(inherited Items[I]);
                end;
        else
                begin
                    if (Index < 0) Or (Index >= Count) then
                        raise EListError.CreateFmt('Index (%d) out of bounds.', [Integer(Index)])
                    else
                        Result := TtsImage(inherited Items[Index]);
                end;
        end;
    end;
end;

procedure TtsImageCollection.SetTsImage(Index: Variant; Value: TtsImage);
var
    I: Integer;
begin
    case VarType(Index) of
        varString:
            begin
                I := NameIndex(Index);
                if I < 0 then
                    raise EListError.CreateFmt('Index ''%s'' not found in imagelist.', [Index]);
            end;
    else
            begin
                if (Index < 0) or (Index >= Count) then
                    raise EListError.CreateFmt('Index (%d) out of bounds.', [Integer(Index)])
                else
                    I := Index;
            end;
    end;

    if I >= 0 then
        if Items[I] <> nil then
            Items[I].Assign(Value);
end;

function TtsImageCollection.GetOwner: TPersistent;
begin
    Result := FImageList;
end;

{TtsImageLink}

constructor TtsImageLink.Create;
begin
    inherited;
    FImageList := nil;
end;

destructor TtsImageLink.Destroy;
begin
    ImageList := nil;
    inherited;
end;

procedure TtsImageLink.SetImageList(Value: TtsImageListComponent);
begin
    if FImageList <> Value then
    begin
        if Assigned(FImageList) then FImageList.RemoveLink(Self);
        if Assigned(Value) then Value.AddLink(Self);
    end;
end;

function TtsImageLink.GetTsImage(Name: Variant): TtsImageItem;
begin
    if Assigned(FImageList) then
        Result := FImageList.Image[Name]
    else
        Result := nil;
end;

procedure TtsImageLink.ImageChanged(Image: TtsImageItem);
begin
end;

procedure TtsImageLink.ImageListDeleted;
begin
end;

end.