gmresource.pas

GmPrintSuite 2.96.7] a

  if FName = Value then Exit;
  FName := Value;
  Changed;
end;

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

// *** TGmFontList ***

function TGmFontList.AddFont(AFont: TGmFont): TGmFont;
var
  NewFont: TGmFont;
  Index: integer;
begin
  Index := IndexOf(AFont);
  if Index > -1 then
  begin
    Result := Self[Index];
    ReferenceList.IncValueAtIndex(Index);
    Exit;
  end;
  NewFont := TGmFont.Create;
  NewFont.Assign(AFont);
  Add(NewFont);
  ReferenceList.AddValue(1);
  Result := NewFont;
end;

procedure TGmFontList.LoadFromStream(Stream: TStream);
var
  ICount,
  NumFonts: integer;
  AFont: TGmFont;
begin
  Clear;
  Stream.ReadBuffer(NumFonts, SizeOf(NumFonts));
  AFont := TGmFont.Create;
  try
    for ICount := 1 to NumFonts do
    begin
      AFont.LoadFromStream(Stream);
      AddFont(AFont);
    end;
  finally
    AFont.Free;
  end;
  FReferenceList.LoadFromStream(Stream);
end;

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

function TGmFontList.GetFont(index: integer): TGmFont;
begin
  Result := TGmFont(Items[index]);
end;

procedure TGmFontList.SetFont(index: integer; AFont: TGmFont);
begin
  Items[index] := AFont;
end;

function TGmFontList.IndexOf(AFont: TGmFont): integer;
var
  ICount: integer;
  CompareFont: TGmFont;
begin
  Result := -1;
  for ICount := 0 to Count-1 do
  begin
    CompareFont := Self[ICount];
    if CompareFonts(CompareFont, AFont) then
    begin
      Result := ICount;
      Exit;
    end;
  end;
end;

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

// *** TGmPen ***

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

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

procedure TGmPen.SetMode(Value: TPenMode);
begin
  if FMode = Value then Exit;
  FMode := Value;
  Changed;
end;

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

procedure TGmPen.SetWidth(Value: integer);
begin
  if FWidth = Value then Exit;
  FWidth := Value;
  Changed;
end;

procedure TGmPen.Assign(Source: TPersistent);
begin
  if (Source is TGmPen) then
  begin
    FWidth := TGmPen(Source).Width;
    FColor := TGmPen(Source).Color;
    FStyle := TGmPen(Source).Style;
    FMode  := TGmPen(Source).Mode;
    Changed;
  end
  else
  if (Source is TPen) then
  begin
    FWidth := TPen(Source).Width;
    FColor := TPen(Source).Color;
    FStyle := TPen(Source).Style;
    FMode  := TPen(Source).Mode;
    Changed;
  end
  else
    inherited Assign(Source);
end;

procedure TGmPen.AssignToCanvas(Canvas: TCanvas; Ppi: integer);
var
  OnePt: Extended;
  LineStyle: Byte;
  AWidth: integer;
  APenStyle: Cardinal;
  lb: TLogBrush;
begin
  OnePt := Ppi / 72;
  Canvas.Pen.Color := FColor;
  Canvas.Pen.Style := FStyle;
  Canvas.Pen.Width := Round((OnePt/4) * FWidth);
  if FColor = clNone then
  begin
    Canvas.Pen.Style := psClear;
    Exit;
  end;
  AWidth := Canvas.Pen.Width;
  lb.lbStyle := BS_SOLID;
  lb.lbColor := ColorToRGB(Canvas.Pen.Color);
  lb.lbHatch := 0;

  LineStyle := PS_SOLID;
  case Canvas.Pen.Style of
    psSolid     : LineStyle := PS_SOLID;
    psDash      : LineStyle := PS_DASH;
    psDot       : LineStyle := PS_DOT;
    psDashDot   : LineStyle := PS_DASHDOT;
    psDashDotDot: LineStyle := PS_DASHDOTDOT;
    psClear     : LineStyle := PS_NULL;
  end;
  APenStyle := PS_GEOMETRIC;
  if (AWidth <= 1) and (LineStyle = PS_SOLID) then
  begin
    AWidth := 1;
    APenStyle := PS_COSMETIC;
  end;

  Canvas.Pen.Handle := ExtCreatePen(APenStyle or
                                    LineStyle or
                                    PS_ENDCAP_SQUARE or
                                    PS_JOIN_MITER,
                                    AWidth,
                                    lb,
                                    0,
                                     nil);
  if FColor = clNone then Canvas.Pen.Style := psClear;
end;

procedure TGmPen.AssignToPen(APen: TPen);
begin
  APen.Color := FColor;
  APen.Style := FStyle;
  APen.Width := FWidth;
end;

procedure TGmPen.LoadFromStream(Stream: TStream);
var
  AValues: TGmValueList;
begin
  AValues := TGmValueList.Create;
  try
    AValues.LoadFromStream(Stream);
    FColor := AValues.ReadIntValue(C_CL, clBlack);
    FWidth := AValues.ReadIntValue(C_SZ, 1);
    FStyle := TPenStyle(AValues.ReadIntValue(C_ST, Ord(psSolid)));
    FMode  := TPenMode(AValues.ReadIntValue(C_PM, Ord(pmCopy)));
  finally
    AValues.Free;
  end;
end;

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

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

// *** TGmPenList ***

function TGmPenList.GetPen(index: integer): TGmPen;
begin
  if index = -1 then
  begin
    Result := nil;
    Exit;
  end;
  Result := TGmPen(Items[index]);
end;

procedure TGmPenList.SetPen(index: integer; APen: TGmPen);
begin
  Items[index] := APen;
end;

function TGmPenList.AddPen(APen: TGmPen): TGmPen;
var
  NewPen: TGmPen;
  Index: integer;
begin
  Index := IndexOf(APen);
  if Index > -1 then
  begin
    Result := Self[Index];
    ReferenceList.IncValueAtIndex(Index);
    Exit;
  end;
  NewPen := TGmPen.Create;
  NewPen.Assign(APen);
  Add(NewPen);
  ReferenceList.AddValue(1);
  Result := NewPen;
end;

function TGmPenList.IndexOf(APen: TGmPen): integer;
var
  ICount: integer;
  ComparePen: TGmPen;
begin
  Result := -1;
  for ICount := 0 to Count-1 do
  begin
    ComparePen := Self[ICount];
    if ComparePens(ComparePen, APen) then
    begin
      Result := ICount;
      Exit;
    end;
  end;
end;

procedure TGmPenList.LoadFromStream(Stream: TStream);
var
  ICount,
  NumPens: integer;
  NewPen: TGmPen;
begin
  Stream.ReadBuffer(NumPens, SizeOf(NumPens));
  NewPen := TGmPen.Create;
  try
    for ICount := 0 to NumPens-1 do
    begin
      NewPen.LoadFromStream(Stream);
      AddPen(NewPen);
    end;
  finally
    NewPen.Free;
  end;
  FReferenceList.LoadFromStream(Stream);
end;

procedure TGmPenList.SaveToStream(Stream: TStream);
var
  WritePen: TGmPen;
  ICount,
  NumPens: integer;
begin
  NumPens := Count;
  Stream.WriteBuffer(NumPens, SizeOf(NumPens));
  for ICount := 0 to Count-1 do
  begin
    WritePen := Pen[ICount];
    WritePen.SaveToStream(Stream);
  end;
  FReferenceList.SaveToStream(Stream);
end;

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

constructor TGmGraphicList.Create;
begin
  inherited Create;
  FGraphicCompare := True;
end;

function TGmGraphicList.GetGraphic(index: integer): TGraphic;
begin
  if index = -1 then
  begin
    Result := nil;
    Exit;
  end;
  Result := TGraphic(Items[index]);
  if (Result is TBitmap) then TBitmap(Result).Handle;
end;

function TGmGraphicList.GetGraphicType(AGraphic: TGraphic): TGmGraphicType;
begin
  Result := gmBitmap;
  if (AGraphic is TJPEGImage) then Result := gmJPeg
  else
  if (AGraphic is TMetafile) then Result := gmMetafile;
end;

procedure TGmGraphicList.SetGraphic(index: integer; Graphic: TGraphic);
begin
  Items[index] := Graphic;
end;

function TGmGraphicList.AddGraphic(AGraphic: TGraphic): TGraphic;
var
  AddGraphic: TGraphic;
  ICount: integer;
  CompareGraphic: TGraphic;
begin
  if FGraphicCompare then
  begin
    for ICount := 0 to Count-1 do
    begin
      CompareGraphic := TGraphic(Self[ICount]);
      if CompareGraphics(AGraphic, CompareGraphic) then
      begin
        Result := TGraphic(Items[ICount]);
        FReferenceList.IncValueAtIndex(ICount);
        Exit;
      end;
    end;
  end;

  if (AGraphic is TJPegImage) then AddGraphic := TJPegImage.Create
  else
  if (AGraphic is TMetafile) then AddGraphic := TMetafile.Create
  else
  if (AGraphic is TBitmap) then AddGraphic := TBitmap.Create
  else
  begin
    Result := nil;
    Exit;
  end;

  AddGraphic.Assign(AGraphic);
  Add(AddGraphic);
  if (AddGraphic is TBitmap) then
    TBitmap(AddGraphic).Dormant;
  FReferenceList.AddValue(1);
  Result := AddGraphic;
end;

function TGmGraphicList.IndexOf(AGraphic: TGraphic): integer;
var
  ICount: integer;
  CompareGraphic: TGraphic;
begin
  Result := -1;
  for ICount := 0 to Count-1 do
  begin
    CompareGraphic := TGraphic(Self[ICount]);
    if CompareGraphics(CompareGraphic, AGraphic) then
    begin
      Result := ICount;
      Exit;
    end;
  end;
end;

procedure TGmGraphicList.LoadFromStream(Stream: TStream);
var
  ICount,
  NumGraphics: integer;
  ReadGraphic: TGraphic;
  GraphicType: TGmGraphicType;
  Marker: integer;
begin
  Stream.ReadBuffer(NumGraphics, SizeOf(NumGraphics));
  for ICount := 0 to NumGraphics-1 do
  begin
    Stream.ReadBuffer(GraphicType, SizeOf(GraphicType));
    ReadGraphic := nil;
    case GraphicType of
      gmJPeg:     ReadGraphic := TJPEGImage.Create;
      gmMetafile: ReadGraphic := TMetafile.Create;
      gmBitmap:   ReadGraphic := TBitmap.Create;
    end;
    Stream.Read(Marker, SizeOf(Marker));
    if Assigned(ReadGraphic) then
    begin
      ReadGraphic.LoadFromStream(Stream);
      Add(ReadGraphic);
    end;
    Stream.Seek(Marker, soFromBeginning);
  end;
  FReferenceList.LoadFromStream(Stream);
end;

procedure TGmGraphicList.SaveToStream(Stream: TStream);
var
  ICount,
  NumGraphics: integer;
  WriteGraphic: TGraphic;
  GraphicType: TGmGraphicType;
  InsertPos: Integer;
  Marker: integer;