teepdfcanvas.pas

来自「Delphi TeeChartPro.6.01的源代码」· PAS 代码 · 共 1,268 行 · 第 1/3 页

PAS
1,268 行
字号
123
    if (Brush.Style<>bsClear) then
    begin
      if (Pen.Style<>psClear) then AddString(sStream,'B')
      else AddString(sStream,'f');
    end else AddString(sStream,'S');
  end;
end;

procedure TPDFCanvas.SetPixel3D(X,Y,Z:Integer; Value: TColor);
begin
  if Pen.Style<>psClear then
  begin
    Calc3DPos(x,y,z);
    Pen.Color:=Value;
    MoveTo(x,y);
    LineTo(x,y);
  end;
end;

procedure TPDFCanvas.SetPixel(X, Y: Integer; Value: TColor);
begin
  if Pen.Style<>psClear then
  begin
    Pen.Color:=Value;
    MoveTo(x,y);
    LineTo(x,y);
  end;
end;

procedure TPDFCanvas.Arc(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4, True,False);
end;

procedure TPDFCanvas.Pie(X1, Y1, X2, Y2, X3, Y3, X4, Y4: Integer);
begin
  InternalDrawArc(X1, Y1, X2, Y2, X3, Y3, X4, Y4, False, True);
end;

procedure TPDFCanvas.RoundRect(X1, Y1, X2, Y2, X3, Y3: Integer);
begin
  InternalRect(TeeRect(X1,Y1,X2,Y2),True,True);
end;

Procedure TPDFCanvas.TextOut3D(X,Y,Z:Integer; const Text:String);
begin
  RotateLabel3D(X,Y,Z,Text,0);
end;

Procedure TPDFCanvas.TextOut(X,Y:Integer; const Text:String);
begin
  TextOut3D(X,Y,0,Text);
end;

procedure TPDFCanvas.MoveTo3D(X,Y,Z:Integer);
begin
  Calc3DPos(x,y,z);
  MoveTo(x,y);
end;

procedure TPDFCanvas.LineTo3D(X,Y,Z:Integer);
begin
  Calc3DPos(x,y,z);
  LineTo(x,y);
end;

Procedure TPDFCanvas.DoHorizLine(X0,X1,Y:Integer);
begin
  MoveTo(X0,Y);
  LineTo(X1,Y);
end;

Procedure TPDFCanvas.DoVertLine(X,Y0,Y1:Integer);
begin
  MoveTo(X,Y0);
  LineTo(X,Y1);
end;

procedure TPDFCanvas.RotateLabel3D(x,y,z:Integer; Const St:String; RotDegree:Integer);

  Procedure DoText(AX,AY: double; RotRad: double);
  var tw,th: double;
      vcos, vsin : double;
      xc,yc: double;
      FontIndex: Integer;
  begin
    AddString(sStream,PDFColor(Font.Color)+' rg');
    AddString(sStream,'BT');
    if Assigned(IFont) then AddString(sStream,FontProperties(IFont,FontIndex))
    else AddString(sStream,FontProperties(TTeeFont(Font),FontIndex));

    { Get text width and height }
    th := TextHeight(St);
    if (TextAlign and TA_CENTER)=TA_CENTER then tw := TextWidth(St)*0.5
    else if (TextAlign and TA_RIGHT)=TA_RIGHT then tw := TextWidth(St)
    else tw := 0 ;

    {$IFNDEF LINUX}
    { FIX :
      the system uses 72 Pixelsperinch as a base line figure, most systems are
      96 DPI or if your in large Font Mode then 120 DPI
      So when using the TextWidth/TextHeight of the currently selected font, you get the wrong answer
    }
    tw := tw*72/PFontEntry(FontList.Items[FontIndex]).FontData.otmTextMetrics.tmDigitizedAspectX;
    th := th*72/PFontEntry(FontList.Items[FontIndex]).FontData.otmTextMetrics.tmDigitizedAspectY;
    {$ENDIF}

    TranslateVertCoord(AY);
    { rotation elements }
    vcos := Cos(RotRad);
    vsin := Sin(RotRad);

    { rotated values }
    xc := AX - (tw*vcos-th*vsin);
    yc := AY - (tw*vsin+th*vcos);
    tmpSt := FormatFloat('0.000',vcos)+ ' ' + FormatFloat('0.000',vsin)+ ' '+
                    FormatFloat('0.000',-vsin)+ ' ' + FormatFloat('0.000',vcos)+ ' '+
                    FormatFloat('0.000',xc)+ ' ' + FormatFloat('0.000',yc)+ ' Tm';

    FixSeparator(tmpSt);
    AddString(sStream,tmpSt);
    AddString(sStream,'('+TextToPDFText(St)+') Tj');
    AddString(sStream,'ET');
  end;

var tmpX : Integer;
    tmpY : Integer;
begin

  Calc3DPos(X,Y,Z);
  if Assigned(IFont) then
  With IFont.Shadow do
  if (HorizSize<>0) or (VertSize<>0) then
  begin
    if HorizSize<0 then
    begin
      tmpX:=X;
      X:=X-HorizSize;
    end
    else tmpX:=X+HorizSize;
    if VertSize<0 then
    begin
      tmpY:=Y;
      Y:=Y-VertSize;
    end
    else tmpY:=Y+VertSize;
    DoText(tmpX,tmpY, RotDegree*0.01745329);
  end;

  DoText(X,Y, RotDegree*0.01745329);
end;

procedure TPDFCanvas.RotateLabel(x,y:Integer; Const St:String; RotDegree:Integer);
begin
  RotateLabel3D(x,y,0,St,RotDegree);
end;

Procedure TPDFCanvas.Line(X0,Y0,X1,Y1:Integer);
begin
  MoveTo(X0,Y0);
  LineTo(X1,Y1);
end;

Procedure TPDFCanvas.HorizLine3D(Left,Right,Y,Z:Integer);
begin
  MoveTo3D(Left,Y,Z);
  LineTo3D(Right,Y,Z);
end;

Procedure TPDFCanvas.VertLine3D(X,Top,Bottom,Z:Integer);
begin
  MoveTo3D(X,Top,Z);
  LineTo3D(X,Bottom,Z);
end;

Procedure TPDFCanvas.ZLine3D(X,Y,Z0,Z1:Integer);
begin
  MoveTo3D(X,Y,Z0);
  LineTo3D(X,Y,Z1);
end;

Procedure TPDFCanvas.LineWithZ(X0,Y0,X1,Y1,Z:Integer);
begin
  MoveTo3D(X0,Y0,Z);
  LineTo3D(X1,Y1,Z);
end;

Function TPDFCanvas.GetBackMode:TCanvasBackMode;
begin
  result:=FBackMode;
end;

Procedure TPDFCanvas.PolygonFour;
begin
  Polygon(IPoints);
end;

Procedure TPDFCanvas.Polygon(const Points: Array of TPoint);
var t: Integer;

begin
  if (Brush.Style<>bsClear) or (Pen.Style<>psClear) then
  begin

    if (Pen.Style<>psClear) then
      AddString(sStream,PenProperties(Pen));

    AddString(sStream,PointToStr(Points[0].X,Points[0].Y)+' m');
    for t:=1 to High(Points) do
      AddString(sStream,PointToStr(Points[t].X,Points[t].Y)+' l');
    AddString(sStream,'h');

    if (Brush.Style<>bsClear) then
    begin
      AddString(sStream,BrushProperties(Brush));
      if (Pen.Style<>psClear) then AddString(sStream,'B')
      else AddString(sStream,'f');
    end else AddString(sStream,'S');
  end;
end;

function TPDFCanvas.InitWindow(DestCanvas: TCanvas;
  A3DOptions: TView3DOptions; ABackColor: TColor; Is3D: Boolean;
  const UserRect: TRect): TRect;
var i: Integer;
begin
  result:=inherited InitWindow(DestCanvas,A3DOptions,ABackColor,Is3D,UserRect);
  IClipCalled := False;
  TheBounds;
  IObjCount := 0;
  ObjectOffset := 0;
  ObjectOffsetList.Clear;
  for i := 0 to FontList.Count -1 do
  begin
    FontEntry := FontList.Items[i];
    Dispose(FontEntry);
  end;
  FontList.Clear;
  { clear all streams }
  PDF.Clear;
  tStream.Clear;
  sStream.Clear;

  DefineHeader;
  StartStream;
end;

function TPDFCanvas.SelectFont(Font: TFont): Integer;
var i: Integer;
  FName : String;
  {$IFNDEF CLX}
  FontInfo: ^TOutlineTextMetric;
  {$ENDIF}
begin
  {$IFDEF CLX}
  result:=-1;
  {$ENDIF}

  FName := ConstructFontName(Font);
  for i := 0 to FontList.Count -1 do
    { Font already in the font list ? }
    if FName = PFontEntry(FontList.Items[i]).UniqueName then
    begin
      Result := i;
      Exit;
    end;

  {$IFNDEF CLX}
  { New font ? Generate entry for it }
  New(FontInfo);
  try
    GetOutlineTextMetrics(Handle,SizeOf(TOutlineTextMetric),FontInfo);
    New(FontEntry);
    FontEntry^.UniqueName := FName;
    FontEntry^.FontData := FontInfo^;
    FontEntry^.Font := Font;
    FontEntry^.Name := 'F'+IntToStr(FontList.Count +1);
    FontList.Add(FontEntry);
    Result := FontList.Count-1;
  finally
    Dispose(FontInfo);
  end;
  {$ENDIF}
end;

procedure TPDFCanvas.WriteTrueTypeFonts;
var
  First, Last: Integer;
  Flags: Integer;
  i,j: Integer;
  MulFactor: double;
  FData : TOutlineTextMetric;
  CharWidths: Array[0..255] of Integer;
begin
  fStream.Clear;
  for i := 0 to FontList.Count -1 do
  begin
    FData := PFontEntry(FontList.Items[i]).FontData;
    ReferenceCanvas.Font.Assign(PFontEntry(FontList.Items[i]).Font);
    {$IFNDEF CLX}
    { TODO : Verify the MulFactor calculation with large/small fonts }
    { Especially why it seems 0.6 is correct factor in both cases ? }
    MulFactor :=FData.otmEMSquare/FData.otmTextMetrics.tmHeight*0.6;
    {$ELSE}
    MulFactor := 1;
    {$ENDIF}
    {$IFNDEF CLX}
    GetCharWidth32(Handle,0,255,CharWidths);
    {$ENDIF}

    {$IFDEF LINUX}
    First := 0;
    Last := 255;
    {$ELSE}
    First := Ord(FData.otmTextMetrics.tmFirstChar);
    Last := Ord(FData.otmTextMetrics.tmLastChar);
    {$ENDIF}

    Flags := 32; { TODO : Missing correct flag calculation }
    { Font header }
    Inc(IObjCount);
    PFontEntry(FontList.Items[i]).ObjPos := IObjCount;
    tStream.Clear;
    AddString(tStream,IntToStr(IObjCount)+' 0 obj');
    AddString(tStream,'<< /Type /Font');
    AddString(tStream,'/Subtype /TrueType');
    AddString(tStream,'/BaseFont /'+PFontEntry(FontList.Items[i]).UniqueName);
    AddString(tStream,'/FirstChar '+IntToStr(First));
    AddString(tStream,'/LastChar '+IntToStr(Last));
    AddString(tStream,'/FontDescriptor '+IntToStr(IObjCount+1)+' 0 R');
    AddString(tStream,'/Widths '+IntToStr(IObjCount+2)+' 0 R');
    AddString(tStream,'/Encoding /WinAnsiEncoding');
    AddString(tStream,'>>');
    AddString(tStream,'endobj');
    AddToOffset(tStream.Size);
    fStream.Seek(0, soFromEnd);
    tStream.SaveToStream(fStream);

    { add font descriptor }
    Inc(IObjCount);
    tStream.Clear;
    AddString(tStream,IntToStr(IObjCount)+' 0 obj');
    AddString(tStream,'<< /Type /FontDescriptor');
    AddString(tStream,'/FontName /'+PFontEntry(FontList.Items[i]).UniqueName);
    AddString(tStream,'/Flags '+IntToStr(Flags));

    {$IFNDEF LINUX}
    AddString(tStream,'/FontBBox ['+
        IntToStr(Round(FData.otmrcFontBox.Left*MulFactor))+' ' +
        IntToStr(Round(FData.otmrcFontBox.Bottom*MulFactor))+' ' +
        IntToStr(Round((FData.otmrcFontBox.right - FData.otmrcFontBox.Left)*MulFactor))+' ' +
        IntToStr(Round((FData.otmrcFontBox.Top - FData.otmrcFontBox.Bottom)*MulFactor))+']');
    AddString(tStream,'/CapHeight '+IntToStr(Round(FData.otmTextMetrics.tmHeight*MulFactor)));
    AddString(tStream,'/Ascent '+IntToStr(Round(FData.otmAscent*MulFactor)));
    AddString(tStream,'/Descent '+IntToStr(-Round(FData.otmDescent*MulFactor)));
    AddString(tStream,'/Leading '+IntToStr(Round(FData.otmTextMetrics.tmInternalLeading*MulFactor)));
    AddString(tStream,'/MaxWidth '+IntToStr(Round(FData.otmTextMetrics.tmMaxCharWidth*MulFactor)));
    AddString(tStream,'/AvgWidth '+IntToStr(Round(FData.otmTextMetrics.tmAveCharWidth*MulFactor)));
    AddString(tStream,'/ItalicAngle '+IntToStr(FData.otmItalicAngle));
    {$ENDIF}

    AddString(tStream,'>>');
    AddString(tStream,'endobj');
    AddToOffset(tStream.Size);
    fStream.Seek(0, soFromEnd);
    tStream.SaveToStream(fStream);

    { write widths }
    Inc(IObjCount);
    tStream.Clear;
    AddString(tStream,IntToStr(IObjCount)+' 0 obj');
    AddString(tStream,'[');
    tmpSt := '';
    for j := First to Last do
      if (j mod 15 = 14) then tmpSt := tmpSt + IntToStr(Round(CharWidths[j]*MulFactor))+' '+#13+#10
      else tmpSt := tmpSt + IntToStr(Round(CharWidths[j]*MulFactor))+' ';
    AddString(tStream,tmpSt);
    AddString(tStream,']');
    AddString(tStream,'endobj');
    AddToOffset(tStream.Size);
    fStream.Seek(0, soFromEnd);
    tStream.SaveToStream(fStream);
  end;
  PDF.Seek(0, soFromEnd);
  fStream.SaveToStream(PDF);
end;

function TPDFCanvas.ConstructFontName(Font: TFont): String;
begin
  tmpSt := Font.Name;
  if (fsBold in Font.Style) then tmpSt := tmpSt+',Bold';
  if (fsItalic in Font.Style) then tmpSt := tmpSt+',Italic';
  Result := StringReplace(tmpSt,' ','#20',[rfReplaceAll]);
end;

procedure TPDFCanvas.DefineCatalog;
begin
  { Catalog part }
  Inc(IObjCount);
  ICatalogNum := IObjCount;
  tStream.Clear;
  AddString(tStream,IntToStr(IObjCount)+' 0 obj');
  AddString(tStream,'<< /Type /Catalog');
  AddString(tStream,'/Pages '+IntToStr(IParentNum)+' 0 R');
  AddString(tStream,'/Outlines '+IntToStr(IOutlineNum)+' 0 R');
  AddString(tStream,'>>');
  AddString(tStream,'endobj');
  AddToOffset(tStream.Size);
  PDF.Seek(0, soFromEnd);
  tStream.SaveToStream(PDF);
end;

procedure TPDFCanvas.DefineOutline;
begin
  { Outline part }
  Inc(IObjCount);
  IOutLineNum := IObjCount;
  tStream.Clear;
  AddString(tStream,IntToStr(IObjCount)+' 0 obj');
  AddString(tStream,'<< /Type /Outlines');
  AddString(tStream,'/Count 0');
  AddString(tStream,'>>');
  AddString(tStream,'endobj');
123

teepdfcanvas.pas - 源码说明

本页面展示了「Delphi TeeChartPro.6.01的源代码」中的 teepdfcanvas.pas 源码文件，采用 PAS 编程语言编写，共 1,268 行代码。您可以在线阅读完整代码内容，也可以返回资源详情页下载完整源码包进行本地学习和开发。

虫虫下载站收录了大量与TeeChartPro相关的技术资源，包括源代码、技术文档、电路图等，是电子工程师和嵌入式开发者的专业学习平台。

⌨️ 快捷键说明

复制代码Ctrl + C
搜索代码Ctrl + F
全屏模式F11
增大字号Ctrl + =
减小字号Ctrl + -
显示快捷键?