gmresource.pas

GmPrintSuite 2.96.7] a

  Result := FList[index];
end;

procedure TGmObjectList.SetItem(index: integer; AObject: TObject);
begin
  FList[index] := AObject;
end;

procedure TGmObjectList.Add(AObject: TObject);
begin
  FList.Add(AObject);
end;


procedure TGmObjectList.Clear;
var
  ICount: integer;
begin
  for ICount := FList.Count-1 downto 0 do
  begin
    Delete(ICount);
  end;
end;

procedure TGmObjectList.Delete(index: integer);
var
  AObject: TObject;
begin
  AObject := FList.Items[index];
  AObject.Free;
  FList.Delete(index);
end;

procedure TGmObjectList.Insert(Index: integer; AObject: TObject);
begin
  FList.Insert(Index, AObject);
end;

{$ENDIF}

//------------------------------------------------------------------------------
// *** TGmReferenceList ***

procedure TGmReferenceList.AddValue(Value: integer);
begin
  Add(IntToStr(Value));
end;

procedure TGmReferenceList.DecValueAtIndex(index: integer);
begin
  Value[index] := Value[index] - 1;
end;

procedure TGmReferenceList.IncValueAtIndex(index: integer);
begin
  Value[index] := Value[index] + 1;
end;

procedure TGmReferenceList.LoadFromStream(Stream: TStream);
var
  ICount: integer;
  NumValues: integer;
  Values: TGmValueList;
begin
  Values := TGmValueList.Create;
  try
    NumValues := Values.ReadIntValue(C_RC, 0);
    for ICount := 1 to NumValues do
      AddValue(Values.ReadIntValue(C_RN+IntToStr(ICount), 0));
  finally
    Values.Free;
  end;
end;

procedure TGmReferenceList.SaveToStream(Stream: TStream);
var
  Values: TGmValueList;
  ICount: integer;
begin
  Values := TGmValueList.Create;
  try
    Values.WriteIntValue(C_RC, Count);
    for ICount := 1 to Count do
      Values.WriteIntValue(C_RN+IntToStr(ICount), Value[ICount-1]);
  finally
    Values.Free;
  end;
end;

function TGmReferenceList.GetValue(index: integer): integer;
begin
  Result := StrToInt(Strings[index]);
end;

procedure TGmReferenceList.SetValue(index: integer; Value: integer);
begin
  Strings[index] := IntToStr(Value);
end;

//------------------------------------------------------------------------------

constructor TGmResourceList.Create;
begin
  inherited Create(True);
  FReferenceList := TGmReferenceList.Create;
end;

destructor TGmResourceList.Destroy;
begin
  FReferenceList.Free;
  inherited Destroy;
end;

procedure TGmResourceList.DeleteResource(AResource: TObject);
var
  Index: integer;
begin
  Index := IndexOf(AResource);
  if Index = -1 then Exit;
  if ReferenceList[Index] = 1 then
  begin
    ReferenceList.Delete(Index);
    Delete(Index);
  end
  else
    ReferenceList.DecValueAtIndex(Index);
end;

//------------------------------------------------------------------------------

// *** TGmBrush ***

constructor TGmBrush.Create;
begin
  inherited Create;
  FColor := clWhite;
  FStyle := bsClear;
end;

procedure TGmBrush.Assign(Source: TPersistent);
begin
  if not Assigned(Source) then Exit;
  if (Source is TGmBrush) then
  begin
    FColor := (Source as TGmBrush).Color;
    FStyle := (Source as TGmBrush).Style;
    Changed;
  end
  else
  if (Source is TBrush) then
  begin
    FColor := (Source as TBrush).Color;
    FStyle := (Source as TBrush).Style;
    Changed;
  end
  else
    inherited Assign(Source);
end;

procedure TGmBrush.AssignToCanvas(ACanvas: TCanvas);
var
  ABrush: TBrush;
begin
  ABrush := TBrush.Create;
  try
    ABrush.Color := FColor;
    if ABrush.Color = clNone then
      ABrush.Style := bsClear
    else
      ABrush.Style := FStyle;
    ACanvas.Brush.Assign(ABrush);
  finally
    ABrush.Free;
  end;
end;

procedure TGmBrush.LoadFromStream(Stream: TStream);
var
  AValues: TGmValueList;
begin
  AValues := TGmValueList.Create;
  try
    AValues.LoadFromStream(Stream);
    FColor := AValues.ReadIntValue(C_CL, clWhite);
    FStyle := TBrushStyle(AValues.ReadIntValue(C_ST, 0));
  finally
    AValues.Free;
  end;
end;

procedure TGmBrush.SaveToStream(Stream: TStream);
var
  AValues: TGmValueList;
begin
  AValues := TGmValueList.Create;
  try
    AValues.WriteIntValue(C_CL, FColor);
    AValues.WriteIntValue(C_ST, Ord(FStyle));
    AValues.SaveToStream(Stream);
  finally
    AValues.Free;
  end;
end;

procedure TGmBrush.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGmBrush.SetColor(const Value: TColor);
begin
  if FColor = Value then Exit;
  FColor := Value;
  FStyle := bsSolid;
  Changed;
end;

procedure TGmBrush.SetStyle(const Value: TBrushStyle);
begin
  if FStyle = Value then Exit;
  FStyle := Value;
  Changed;
end;

//------------------------------------------------------------------------------

// *** TGmBrushList ***

function TGmBrushList.GetBrush(index: integer): TGmBrush;
begin
  if index = -1 then
  begin
    Result := nil;
    Exit;
  end;
  Result := TGmBrush(Items[index]);
end;

procedure TGmBrushList.SetBrush(index: integer; ABrush: TGmBrush);
begin
  Items[index] := ABrush;
end;

function TGmBrushList.AddBrush(ABrush: TGmBrush): TGmBrush;
var
  NewBrush: TGmBrush;
  Index: integer;
begin
  Index := IndexOf(ABrush);
  if Index > -1 then
  begin
    Result := Self[Index];
    ReferenceList.IncValueAtIndex(Index);
    Exit;
  end;
  NewBrush := TGmBrush.Create;
  NewBrush.Assign(ABrush);
  Add(NewBrush);
  ReferenceList.AddValue(1);
  Result := NewBrush;
end;

function TGmBrushList.IndexOf(ABrush: TGmBrush): integer;
var
  ICount: integer;
  CompareBrush: TGmBrush;
begin
  Result := -1;
  for ICount := 0 to Count-1 do
  begin
    CompareBrush := Self[ICount];
    if CompareBrushes(CompareBrush, ABrush) then
    begin
      Result := ICount;
      Exit;
    end;
  end;
end;

procedure TGmBrushList.LoadFromStream(Stream: TStream);
var
  ICount,
  NumBrushes: integer;
  ABrush: TGmBrush;
begin
  Clear;
  Stream.ReadBuffer(NumBrushes, SizeOf(NumBrushes));
  ABrush := TGmBrush.Create;
  try
    for ICount := 1 to NumBrushes do
    begin
      ABrush.LoadFromStream(Stream);
      AddBrush(ABrush);
    end;
  finally
    ABrush.Free;
  end;
  FReferenceList.LoadFromStream(Stream);
end;

procedure TGmBrushList.SaveToStream(Stream: TStream);
var
  ICount,
  NumBrushes: integer;
begin
  NumBrushes := Count;
  Stream.WriteBuffer(NumBrushes, SizeOf(NumBrushes));
  for ICount := 0 to NumBrushes-1 do
    Brush[ICount].SaveToStream(Stream);
  FReferenceList.SaveToStream(Stream);
end;

//------------------------------------------------------------------------------

// *** TGmFont ***

constructor TGmFont.Create;
begin
  inherited Create;
  FSize := 12;
  FStyle := [];
  FCharset := DEFAULT_CHARSET;
  FAngle := 0;
  FColor := clBlack;
end;

procedure TGmFont.Assign(Source: TPersistent);
begin
  if (Source is TFont) then
  begin
    FSize     := (Source as TFont).Size;
    FColor    := (Source as TFont).Color;
    FCharset  := (Source as TFont).Charset;
    FName     := (Source as TFont).Name;
    FStyle    := (Source as TFont).Style;
    FAngle    := 0;
  end
  else
  if (Source is TGmFont) then
  begin
    FSize     := (Source as TGmFont).Size;
    FColor    := (Source as TGmFont).Color;
    FCharset  := (Source as TGmFont).Charset;
    FName     := (Source as TGmFont).Name;
    FStyle    := (Source as TGmFont).Style;
    FAngle    := (Source as TGmFont).Angle;
  end
  else
    inherited Assign(Source);
end;

procedure TGmFont.AssignToCanvas(ACanvas: TCanvas);
begin
  AssignToFont(ACanvas.Font);
end;

procedure TGmFont.AssignToFont(AFont: TFont);
var
  logFont : TLogFont;
begin
  AFont.Color := FColor;
  AFont.Size := FSize;
  AFont.Name := FName;
  AFont.Charset := FCharset;
  AFont.Style := FStyle;
  if FAngle <> 0 then
  begin
    GetObject(AFont.Handle, sizeof(logFont), @logFont);
    logFont.lfEscapement := Round(FAngle * 10);
    logFont.lfOrientation := Round(FAngle * 10);
    AFont.Handle := CreateFontIndirect(logFont);
  end;
end;

procedure TGmFont.LoadFromStream(Stream: TStream);
var
  AValues: TGmValueList;
begin
  AValues := TGmValueList.Create;
  try
    AValues.LoadFromStream(Stream);
    FColor   := AValues.ReadIntValue(C_CL, clWhite);
    FStyle   := FontStyleFromString(AValues.ReadStringValue(C_ST, ''));
    FName    := AValues.ReadStringValue(C_FN, DEFAULT_FONT);
    FSize    := AValues.ReadIntValue(C_SZ, DEFAULT_FONT_SIZE);
    FAngle   := AValues.ReadExtValue(C_FA, 0);
    FCharset := AValues.ReadIntValue(C_CS, DEFAULT_CHARSET);
  finally
    AValues.Free;
  end;
end;

procedure TGmFont.SaveToStream(Stream: TStream);
var
  AValues: TGmValueList;
begin
  AValues := TGmValueList.Create;
  try
    AValues.WriteIntValue(C_CL, FColor);
    AValues.WriteStringValue(C_ST, FontStyleToString(FStyle));
    AValues.WriteExtValue(C_FA, FAngle);
    AValues.WriteIntValue(C_SZ, FSize);
    AValues.WriteIntValue(C_CS, Ord(FCharset));
    AValues.WriteStringValue(C_FN, FName);
    AValues.SaveToStream(Stream);
  finally
    AValues.Free;
  end;
end;

procedure TGmFont.Changed;
begin
  if Assigned(FOnChange) then FOnChange(Self);
end;

procedure TGmFont.SetSize(Value: integer);
begin
  if FSize = Value then Exit;
  FSize := Value;
  Changed;
end;

procedure TGmFont.SetStyle(Value: TFontStyles);
begin
  if FStyle = Value then Exit;
  FStyle := Value;
  Changed;
end;

procedure TGmFont.SetAngle(Value: Extended);
begin
  if FAngle = Value then Exit;
  FAngle := Value;
  Changed;
end;

procedure TGmFont.SetColor(Value: TColor);
begin
  if FColor = Value then Exit;
  FColor := Value;
  Changed;
end;

procedure TGmFont.SetCharset(Value: TFontCharset);
begin
  if FCharset = Value then Exit;
  FCharset := Value;
  Changed;
end;

procedure TGmFont.SetName(Value: string);
begin