gmresource.pas

GmPrintSuite 2.96.7] a

begin
  NumGraphics := Count;
  Stream.WriteBuffer(NumGraphics, SizeOf(NumGraphics));
  for ICount := 0 to Count-1 do
  begin
    WriteGraphic := Graphic[ICount];
    GraphicType := GetGraphicType(WriteGraphic);
    Stream.WriteBuffer(GraphicType, SizeOf(GraphicType));
    InsertPos := Stream.Position;
    Stream.Seek(4, soFromCurrent);
    WriteGraphic.SaveToStream(Stream);
    Stream.Seek(InsertPos, soFromBeginning);
    Marker := Stream.Size;
    Stream.WriteBuffer(Marker, SizeOf(Marker));
    Stream.Seek(0, soFromEnd);
  end;
  FReferenceList.SaveToStream(Stream);
end;

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

// *** TGmCustomMemoList ***

constructor TGmCustomMemoList.Create;
begin
  inherited Create;
  FParentForm := TForm.Create(nil);
  FParentForm.Width := 0;
  FParentForm.Height := 0;
  FParentForm.BorderStyle := bsNone;
  FParentForm.Visible := True;
end;

destructor TGmCustomMemoList.Destroy;
begin
  inherited Destroy;
  FParentForm.Free;
end;

function TGmCustomMemoList.CreateMemo: TCustomMemo;
begin
  Result := nil;
  if Assigned(FNeedRichEdit) then FNeedRichEdit(Self, Result);
  if Result = nil then
    Result := CreateTRichEdit
  else
  begin
    Result.Width := 0;
    Result.Height := 0;
  end;
  Result.Parent := FParentForm;
end;

function TGmCustomMemoList.GetMemo(index: integer): TCustomMemo;
begin
  if index = -1 then
  begin
    Result := nil;
    Exit;
  end;
  Result := TCustomMemo(Items[index]);
end;

function TGmCustomMemoList.GetMemoType(AMemo: TCustomMemo): TGmMemoType;
begin
  if AMemo.ClassName = 'TMemo' then
    Result := gmMemo
  else
    Result := gmRichEdit;
end;

procedure TGmCustomMemoList.SetMemo(index: integer; AMemo: TCustomMemo);
begin
  Items[index] := AMemo;
end;

function TGmCustomMemoList.AddMemo(AMemo: TCustomMemo): TCustomMemo;
var
  MemoIndex: integer;
  AddMemo: TCustomMemo;
  AText: string;
begin
  MemoIndex := IndexOf(AMemo);
  if MemoIndex <> -1 then
  begin
    Result := TCustomMemo(Items[MemoIndex]);
    FReferenceList.IncValueAtIndex(MemoIndex);
    Exit;
  end;
  AddMemo := CreateMemo;
  AText := GetRtfText(AMemo);
  AddMemo.Parent := FParentForm;
  // showing and hiding the below form will trigger the "OnActivate" event of
  // the active form in the application.  This is unavoidable as the TRichEdit's
  // parent form has to be Visible to work under Windows 98.
  //FParentForm.Visible := True;
  try
    InsertRtfText(AddMemo, AText);
  finally
  //  FParentForm.Visible := False;
  end;
  if AddMemo.Lines.Text = '' then;
  Add(AddMemo);
  FReferenceList.AddValue(1);
  Result := AddMemo;
end;

function TGmCustomMemoList.IndexOf(AMemo: TCustomMemo): integer;
var
  ICount: integer;
  FindMemo,
  CompareMemo: TCustomMemo;
begin
  Result := -1;
  FindMemo := AMemo;
  for ICount := 0 to Count-1 do
  begin
    CompareMemo := TCustomMemo(Self[ICount]);
    if FindMemo = CompareMemo then
    begin
      Result := ICount;
      Exit;
    end;
  end;
end;

procedure TGmCustomMemoList.LoadFromStream(Stream: TStream);
var
  ICount,
  NumMemos: integer;
  ReadMemo: TCustomMemo;
  MemoType: TGmMemoType;
  ATextStream: TMemoryStream;
  Reader: TGmReader;
begin
  Reader := TGmReader.Create(Stream);
  try
    NumMemos := Reader.ReadInteger;
    for ICount := 0 to NumMemos-1 do
    begin
      MemoType := TGmMemoType(Reader.ReadInteger);
      if MemoType = gmMemo then
      begin
        ReadMemo := CreateTRichEdit;
        TRichEdit(ReadMemo).PlainText := True;
      end
      else
        ReadMemo := CreateMemo;
      ReadMemo.Parent := FParentForm;
      ATextStream := TMemoryStream.Create;
      try
        Reader.ReadStream(ATextStream);
        ATextStream.Seek(0, soFromBeginning);
        InsertRtfStream(ReadMemo, ATextStream);
      finally
        ATextStream.Free;
      end;
      AddMemo(ReadMemo);
    end;
  finally
    Reader.Free;
  end;
  FReferenceList.LoadFromStream(Stream);
end;

procedure TGmCustomMemoList.SaveToStream(Stream: TStream);
var
  ICount,
  NumMemos: integer;
  WriteMemo: TCustomMemo;
  MemoType: TGmMemoType;
  ATextStream: TStringStream;
  Writer: TGmWriter;
begin
  NumMemos := Count;
  Writer := TGmWriter.Create(Stream);
  try
    Writer.WriteInteger(NumMemos);

    for ICount := 0 to Count-1 do
    begin
      WriteMemo := Memo[ICount];
      MemoType := GetMemoType(WriteMemo);
      Writer.WriteInteger(Ord(MemoType));
      ATextStream := TStringStream.Create('');
      try
        ATextStream.WriteString(GetRtfText(WriteMemo));
        ATextStream.Seek(0, soFromBeginning);
        Writer.WriteStream(ATextStream);
      finally
        ATextStream.Free;
      end;
    end;
  finally
    Writer.Free;
  end;
  FReferenceList.SaveToStream(Stream);
end;

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

// *** TGmResourceTable ***

constructor TGmResourceTable.Create;
begin
  inherited Create;
  FBrushList := TGmBrushList.Create;
  FFontList := TGmFontList.Create;
  FPenList := TGmPenList.Create;
  FGraphicList := TGmGraphicList.Create;
  FCustomMemoList := TGmCustomMemoList.Create;
end;

destructor TGmResourceTable.Destroy;
begin
  FBrushList.Free;
  FFontList.Free;
  FPenList.Free;
  FGraphicList.Free;
  FCustomMemoList.Free;
  inherited Destroy;
end;

procedure TGmResourceTable.Clear;
begin
  FBrushList.Clear;
  FFontList.Clear;
  FPenList.Clear;
  FGraphicList.Clear;
  FCustomMemoList.Clear;
end;

procedure TGmResourceTable.LoadFromStream(Stream: TStream);
begin
  FBrushList.LoadFromStream(Stream);
  FFontList.LoadFromStream(Stream);
  FPenList.LoadFromStream(Stream);
  FGraphicList.LoadFromStream(Stream);
  FCustomMemoList.LoadFromStream(Stream);
end;

procedure TGmResourceTable.SaveToStream(Stream: TStream);
begin
  FBrushList.SaveToStream(Stream);
  FFontList.SaveToStream(Stream);
  FPenList.SaveToStream(Stream);
  FGraphicList.SaveToStream(Stream);
  FCustomMemoList.SaveToStream(Stream);
end;

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

// *** TGmFontMapper ***

constructor TGmFontMapper.Create;
begin
  inherited Create;
  if (ReturnOSVersion = 'Windows 98') or
     (ReturnOSVersion = 'Windows 95') then
    CALC_PPI := 14400 div 4
  else
    CALC_PPI := 14400 div 2;

  FCalcPpi := CALC_PPI;
  FRenderBitmap := TBitmap.Create;
  FRenderBitmap.Canvas.Font.PixelsPerInch := FCalcPpi;
  FWrapText := True;
end;

destructor TGmFontMapper.Destroy;
begin
  FRenderBitmap.Free;
  inherited Destroy;
end;

function TGmFontMapper.TextExtent(ACanvas: TCanvas; AText: string): TGmSize;
var
  FontSize: integer;
  Ppi: integer;
begin
  FRenderBitmap.Canvas.Font.Assign(ACanvas.Font);
  FontSize := ACanvas.Font.Size;
  FRenderBitmap.Canvas.Font.PixelsPerInch := FCalcPpi;
  FRenderBitmap.Canvas.Font.Size := FontSize;
  Ppi := FCalcPpi;
  Result.Width := FRenderBitmap.Canvas.TextWidth(AText) / Ppi;
  Result.Height := FRenderBitmap.Canvas.TextHeight(AText) / Ppi;
end;

function TGmFontMapper.TextHeight(ACanvas: TCanvas; AText: string): Extended;
begin
  Result := TextExtent(ACanvas, AText).Height;
end;

function TGmFontMapper.TextWidth(ACanvas: TCanvas; AText: string): Extended;
begin
  Result := TextExtent(ACanvas, AText).Width;
end;

function TGmFontMapper.TextBox(ACanvas: TCanvas; ARect: TRect; AText: string; Alignment: TAlignment; const AFastDraw: Boolean = False): Extended;

  function GetNextWord(var AText: string): string;
  var
    NextSpace: integer;
    NextCr: integer;
    LineBreak: string;
  begin
    NextSpace := Pos(' ', AText);
    LineBreak := #13;
    NextCr := Pos(LineBreak, AText);
    if (NextSpace = 0) and (NextCr > 0) then NextSpace := NextCr
    else
    if (NextCr <> 0) and (NextCr < NextSpace) then NextSpace := NextCr;
    if NextSpace = 0 then NextSpace := Length(AText);
    Result := Copy(AText, 1, NextSpace);
    Delete(AText, 1, NextSpace);
  end;

  procedure DrawLine(ACanvas: TCanvas; ARect: TRect; LineNum: integer; AText: string; Align: TAlignment; AFastDraw: Boolean);
  var
    LineWidth: integer;
    XPos: integer;
    TextBoxWidth: integer;
  begin
    AText := TrimRight(AText);
    TextBoxWidth := ARect.Right - ARect.Left;
    LineWidth := Round(GmFontMapper.TextWidth(ACanvas, AText) * FDestPpi);
    XPos := ARect.Left;
    case Alignment of
      taCenter:      XPos := ARect.Left + (TextBoxWidth - LineWidth) div 2;
      taRightJustify:Xpos := ARect.Left + (TextBoxWidth - LineWidth);
    end;
    TextOut(ACanvas,
            XPos,
            ARect.Top + Round((GmFontMapper.TextHeight(ACanvas, AText) * LineNum) * FDestPpi),
            @ARect,
            AText,
            AFastDraw);
  end;

var
  LineNum: integer;
  str: string;
  NextWord: string;
  TextBoxWidth: Extended;
  CurrentLine: string;
  LineWidth: Extended;
  BreakLine: Boolean;
begin
  if AFastDraw then
    FCalcPpi := SCREEN_PPI
  else
    FCalcPpi := CALC_PPI;

  FDestPpi := ACanvas.Font.PixelsPerInch;
  LineNum := 0;
  CurrentLine := '';
  TextBoxWidth := (ARect.Right - ARect.Left) / FDestPpi;
  BreakLine := False;
  Str := AText;
  Str := ReplaceStringFields(Str, #13#10, #13);
  while Length(str) > 0 do
  begin
    NextWord := GetNextWord(str);
    LineWidth :=  GmFontMapper.TextWidth(ACanvas, CurrentLine + NextWord);
    if ((LineWidth > TextBoxWidth) or (BreakLine)) and (FWrapText) then
    begin
      if GmFontMapper.TextWidth(ACanvas, NextWord) > TextBoxWidth then
      begin
        CurrentLine := CurrentLine + NextWord;
        NextWord := '';
      end;
      DrawLine(ACanvas, ARect, LineNum, CurrentLine, taLeftJustify, AFastDraw);
      CurrentLine := '';
      Inc(LineNum);
      BreakLine := False;
    end;
    CurrentLine := CurrentLine + NextWord;
    if NextWord <> '' then
    begin
      if NextWord[Length(NextWord)] = #13 then BreakLine := True;
    end;
  end;
  if CurrentLine <> '' then
  begin
    DrawLine(ACanvas, ARect, LineNum, CurrentLine, taLeftJustify, AFastDraw);
    Inc(LineNum);
  end;
  Result := (GmFontMapper.TextHeight(ACanvas, AText) * LineNum);
end;

function TGmFontMapper.TextBoxHeight(AFont: TFont; ARect: TRect; AText: string): Extended;
begin
  FRenderBitmap.Canvas.Font.PixelsPerInch := FCalcPpi;
  FRenderBitmap.Canvas.Font.Assign(AFont);
  Result := TextBox(FRenderBitmap.Canvas, ARect,AText, taLeftJustify);
end;

procedure TGmFontMapper.TextOut(ACanvas: TCanvas; X, Y: integer; ARect: PRect; AText: string; const AFastDraw: Boolean = False);
begin
  if AFastDraw then
    FCalcPpi := SCREEN_PPI
  else
    FCalcPpi := CALC_PPI;
  FDestPpi := ACanvas.Font.PixelsPerInch;
  SetLength(FCharSpacing, 0);
  FRenderBitmap.Canvas.Font.PixelsPerInch := FCalcPpi;
  FRenderBitmap.Canvas.Font.Assign(ACanvas.Font);
  CalculateCharSpacing(FRenderBitmap.Canvas, AText);
  GmDrawText(ACanvas, X, Y, ARect, AText, FCharSpacing);
end;

procedure TGmFontMapper.GmDrawText(ACanvas: TCanvas; X, Y: integer; ARect: PRect; AText: string; const Spacing: array of integer);
begin
  if (High(Spacing) = -1) or (ReturnOSVersion = 'Windows NT') then
    ExtTextOut(ACanvas.Handle, X, Y, ETO_CLIPPED, ARect, PChar(AText), Length(AText), nil)
  else
    ExtTextOut(ACanvas.Handle, X, Y, ETO_CLIPPED, ARect, PChar(AText), Length(AText), @Spacing);
end;

procedure TGmFontMapper.CalculateCharSpacing(ACanvas: TCanvas; AText: string);
var
  CharSpacing: Extended;
  ICount: integer;
  ExtraKern: Extended;
begin
  ExtraKern := 0;
  SetLength(FCharSpacing, Length(AText));
  for ICount := 0 to Length(AText)-1 do
  begin
    CharSpacing := (ACanvas.TextWidth(AText[ICount+1]) / FCalcPpi) * FDestPpi;
    FCharSpacing[ICount] := Trunc(CharSpacing);
    ExtraKern := ExtraKern + Frac(CharSpacing);
    if ExtraKern > 1 then
    begin
      FCharSpacing[ICount] := FCharSpacing[ICount] + Trunc(ExtraKern);
      ExtraKern := ExtraKern - Round(ExtraKern);
    end;
  end;
end;

initialization
  GmFontMapper := TGmFontMapper.Create;

finalization
  GmFontMapper.Free;

end.