vrclasses.pas

作工控的好控件

      EndUpdate;
    end;
    Exit;
  end;
  inherited Assign(Source);
end;

procedure TVrGlyphs.SetBitmap(Value: TBitmap);
begin
  FBitmap.Assign(Value);
  Changed;
end;

procedure TVrGlyphs.SetNumGlyphs(Value: TVrNumGlyphs);
begin
  if FNumGlyphs <> Value then
  begin
    FNumGlyphs := Value;
    Changed;
  end;
end;

{ TVrBitmaps }

constructor TVrBitmaps.Create;
begin
  inherited;
  FItems := TList.Create;
end;

destructor TVrBitmaps.Destroy;
begin
  OnChange := nil;
  if FItems <> nil then Clear;
  FItems.Free;
  inherited Destroy;
end;

procedure TVrBitmaps.Clear;
var
  I: Integer;
begin
  BeginUpdate;
  try
    for I := 0 to Count - 1 do
      TBitmap(FItems[I]).Free;
    FItems.Clear;
  finally
    EndUpdate;
  end;
  Changed;
end;

function TVrBitmaps.Add(Value: TBitmap): Integer;
begin
  Result := FItems.Add(nil);
  FItems[Result] := TBitmap.Create;
  Bitmaps[Result].Assign(Value);
  Changed;
end;

procedure TVrBitmaps.Insert(Index: Integer; Value: TBitmap);
begin
  FItems.Insert(Index, nil);
  FItems[Index] := TBitmap.Create;
  Bitmaps[Index].Assign(Value);
  Changed;
end;

procedure TVrBitmaps.Delete(Index: Integer);
begin
  TBitmap(FItems[Index]).Free;
  FItems.Delete(Index);
  Changed;
end;

procedure TVrBitmaps.Exchange(Index1, Index2: Integer);
begin
  FItems.Exchange(Index1, Index2);
  Changed;
end;

function TVrBitmaps.IndexOf(Bitmap: TBitmap): Integer;
begin
  Result := FItems.IndexOf(Bitmap);
end;

procedure TVrBitmaps.Move(CurIndex, NewIndex: Integer);
begin
  FItems.Move(CurIndex, NewIndex);
  Changed;
end;

function TVrBitmaps.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TVrBitmaps.GetBitmap(Index: Integer): TBitmap;
begin
  Result := FItems[Index];
end;

procedure TVrBitmaps.SetBitmap(Index: Integer; Value: TBitmap);
begin
  Bitmaps[Index].Assign(Value);
  Changed;
end;

procedure TVrBitmaps.Assign(Source: TPersistent);
var
  I: Integer;
begin
  if Source = nil then Clear
  else if Source is TVrBitmaps then
  begin
    BeginUpdate;
    try
      Clear;
      for I := 0 to TVrBitmaps(Source).Count - 1 do
        Add(TVrBitmaps(Source).Bitmaps[I]);
    finally
      EndUpdate;
    end;
  end;
end;

procedure TVrBitmaps.ReadData(Stream: TStream);
begin
  BeginUpdate;
  try
    Clear;
    LoadFromStream(Stream);
  finally
    EndUpdate;
  end;
end;

procedure TVrBitmaps.WriteData(Stream: TStream);
begin
  BeginUpdate;
  try
    SaveToStream(Stream);
  finally
    EndUpdate;
  end;
end;

procedure TVrBitmaps.DefineProperties(Filer: TFiler);

  function DoWrite: Boolean;
  begin
    Result := Count > 0;
  end;

begin
  Filer.DefineBinaryProperty('Bitmaps', ReadData, WriteData, DoWrite);
end;

procedure TVrBitmaps.LoadFromStream(Stream: TStream);
var
  Bitmap: TBitmap;
  I, Id, Cnt: Integer;
begin
  Bitmap := TBitmap.Create;
  try
    Stream.Read(Id, Sizeof(Integer));
    if BitmapsFileId <> Id then
      raise Exception.Create('Invalid file format');
    Stream.Read(Cnt, Sizeof(Integer));
    for I := 0 to Cnt - 1 do
    begin
      Bitmap.LoadFromStream(Stream);
      Add(Bitmap);
    end;
  finally
    Bitmap.Free;
  end;
end;

procedure TVrBitmaps.SaveToStream(Stream: TStream);
var
  I, Cnt: Integer;
begin
  Stream.Write(BitmapsFileId, Sizeof(Integer));
  Cnt := Count;
  Stream.Write(Cnt, Sizeof(Integer));
  for I := 0 to Count - 1 do
    TBitmap(Bitmaps[I]).SaveToStream(Stream);
end;

procedure TVrBitmaps.LoadFromFile(const FileName: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmOpenRead);
  try
    BeginUpdate;
    try
      LoadFromStream(Stream);
    finally
      EndUpdate;
    end;
  finally
    Stream.Free;
  end;
end;

procedure TVrBitmaps.SaveToFile(const FileName: string);
var
  Stream: TFileStream;
begin
  Stream := TFileStream.Create(FileName, fmCreate);
  try
    SaveToStream(Stream);
  finally
    Stream.Free;
  end;
end;

{ TVrIntList }

constructor TVrIntList.Create;
begin
  inherited Create;
  FCount := 0;
  FCapacity := 0;
end;

destructor TVrIntList.Destroy;
begin
  Clear;
  inherited Destroy;
end;

procedure TVrIntList.Clear;
begin
  SetCount(0);
  SetCapacity(0);
end;

function TVrIntList.GetCount: Integer;
begin
  Result := FCount;
end;

function TVrIntList.GetItem(Index: Integer): Integer;
begin
  Result := FItems[Index];
end;

function TVrIntList.Add(Value: Integer): Integer;
begin
  Result := FCount;
  if Result = FCapacity then Grow;
  FItems^[Result] := Value;
  Inc(FCount);
end;

procedure TVrIntList.Delete(Index: Integer);
begin
  if (Index < 0) or (Index >= FCount) then
    Exception.Create('TVrIntList index out of bounds');
  Dec(FCount);
  if Index < FCount then
    System.Move(FItems^[Index + 1], FItems^[Index],
    (FCount - Index) * SizeOf(Integer));
end;

procedure TVrIntList.Grow;
var
  Delta: Integer;
begin
  if FCapacity > 64 then Delta := FCapacity div 4 else
    if FCapacity > 8 then Delta := 16 else
      Delta := 4;
  SetCapacity(FCapacity + Delta);
end;

procedure TVrIntList.SetCapacity(NewCapacity: Integer);
begin
  if (NewCapacity < FCount) or (NewCapacity > MaxIntListSize) then
    Exception.Create('TVrIntList Capacity overrun');
  if NewCapacity <> FCapacity then
  begin
    ReallocMem(FItems, NewCapacity * SizeOf(Integer));
    FCapacity := NewCapacity;
  end;
end;

procedure TVrIntList.SetCount(NewCount: Integer);
begin
  if (NewCount < 0) or (NewCount > MaxListSize) then
    Exception.Create('TVrIntList Count overrun');
  if NewCount > FCapacity then SetCapacity(NewCount);
  if NewCount > FCount then
    FillChar(FItems^[FCount], (NewCount - FCount) * SizeOf(Integer), 0);
  FCount := NewCount;
end;

{ TVrRect }

constructor TVrRect.Create;
begin
  FLeft := 0;
  FTop := 0;
  FWidth := 0;
  FHeight := 0;
end;

procedure TVrRect.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if (FLeft <> ALeft) or (FTop <> ATop) or
     (FWidth <> AWidth) or (FHeight <> AHeight) then
  begin
    FLeft := ALeft;
    FTop := ATop;
    FWidth := AWidth;
    FHeight := AHeight;
    Changed;
  end;
end;

procedure TVrRect.Assign(Source: TPersistent);
begin
  if (Source <> nil) and (Source is TVrRect) then
  begin
    BeginUpdate;
    try
      Left := (Source as TVrRect).Left;
      Top := (Source as TVrRect).Top;
      Width := (Source as TVrRect).Width;
      Height := (Source as TVrRect).Height;
    finally
      EndUpdate;
    end;
  end;
  inherited Assign(Source);
end;

procedure TVrRect.SetLeft(Value: Integer);
begin
  SetBounds(Value, FTop, FWidth, FHeight);
end;

procedure TVrRect.SetTop(Value: Integer);
begin
  SetBounds(FLeft, Value, FWidth, FHeight);
end;

procedure TVrRect.SetWidth(Value: Integer);
begin
  SetBounds(FLeft, FTop, Value, FHeight);
end;

procedure TVrRect.SetHeight(Value: Integer);
begin
  SetBounds(FLeft, FTop, FWidth, Value);
end;

function TVrRect.GetBoundsRect: TRect;
begin
  Result.Left := Left;
  Result.Top := Top;
  Result.Right := Left + Width;
  Result.Bottom := Top + Height;
end;

procedure TVrRect.SetBoundsRect(const Rect: TRect);
begin
  with Rect do SetBounds(Left, Top, Right - Left, Bottom - Top);
end;

{ TVrCollectionItem }

constructor TVrCollectionItem.Create(Collection: TVrCollection);
begin
  SetCollection(Collection);
end;

destructor TVrCollectionItem.Destroy;
begin
  SetCollection(nil);
  inherited Destroy;
end;

procedure TVrCollectionItem.Changed(AllItems: Boolean);
var
  Item: TVrCollectionItem;
begin
  if (FCollection <> nil) and (FCollection.FUpdateCount = 0) then
  begin
    if AllItems then Item := nil
    else Item := Self;
    FCollection.Update(Item);
  end;
end;

procedure TVrCollectionItem.SetCollection(Value: TVrCollection);
begin
  if FCollection <> Value then
  begin
    if FCollection <> nil then FCollection.RemoveItem(Self);
    if Value <> nil then Value.InsertItem(Self);
  end;
end;

{ TVrCollection }

constructor TVrCollection.Create;
begin
  FItems := TList.Create;
end;

destructor TVrCollection.Destroy;
begin
  FUpdateCount := 1;
  if FItems <> nil then Clear;
  FItems.Free;
  inherited Destroy;
end;

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

procedure TVrCollection.Changed;
begin
  if FUpdateCount = 0 then Update(nil);
end;

procedure TVrCollection.Clear;
begin
  if FItems.Count > 0 then
  begin
    BeginUpdate;
    try
      while FItems.Count > 0 do TCollectionItem(FItems.Last).Free;
    finally
      EndUpdate;
    end;
  end;
end;

procedure TVrCollection.EndUpdate;
begin
  Dec(FUpdateCount);
  Changed;
end;

procedure TVrCollection.RemoveItem(Item: TVrCollectionItem);
begin
  FItems.Remove(Item);
  Item.FCollection := nil;
end;

procedure TVrCollection.InsertItem(Item: TVrCollectionItem);
begin
  Item.Index := FItems.Add(Item);
  Item.FCollection := Self;
end;

function TVrCollection.GetCount: Integer;
begin
  Result := FItems.Count;
end;

function TVrCollection.GetItem(Index: Integer): TVrCollectionItem;
begin
  Result := FItems[Index];
end;

procedure TVrCollection.Update(Item: TVrCollectionItem);
begin
end;



end.