www.pudn.com > PDF-Library.rar > QPDFFrontEnd.pas, change:2016-12-27,size:55375b


unit QPDFFrontEnd; 
 
interface 
 
uses 
    Windows, Classes, Contnrs, QPDFTTF, QPDFHash, Graphics, jpeg; 
 
type 
    TPdfContext = class; 
 
    TPdfObject = class 
    protected 
        FContext: TPdfContext; 
        FStringContent: String; 
        FRefID: Integer; 
        FParent: TPdfObject; 
    public 
        constructor Create; overload; 
        constructor Create( value: String ); overload; 
        constructor Create( value: Integer ); overload; 
        constructor Create( value: Extended ); overload; 
        procedure Fatal( msg: String ); 
        procedure Print; virtual; 
        procedure PrintFull; virtual; 
        procedure PrintRef; 
        function  GetRef: String; 
        property  Context: TPdfContext read FContext; 
    end; 
 
    TPdfArray = class(TPdfObject) 
    private 
        FArray: TObjectList; 
        function GetItems(Index: Integer): TPdfObject; 
    public 
        constructor Create; overload; 
        constructor Create( arr: array of const ); overload; 
        destructor Destroy; override; 
        procedure PrintFull; override; 
        procedure Add( obj: TPdfObject ); overload; 
        procedure Add( arr: array of const ); overload; 
        function Count: Integer; 
        property Items[Index: Integer]: TPdfObject read GetItems; default; 
    end; 
 
    TPdfDictionary = class(TPdfObject) 
    private 
        FDict: TStringList; 
        function GetItems(Index: String): TPdfObject; 
        procedure SetItems(Index: String; const Value: TPdfObject); 
        function Find(name: String; var Index: Integer): Boolean; 
    public 
        constructor Create; overload; 
        constructor Create( typ: String ); overload; 
        constructor Create( arr: array of const ); overload; 
        destructor Destroy; override; 
        procedure Print; override; 
        procedure PrintFull; override; 
        procedure Add( name: String; obj: TPdfObject ); overload; 
        procedure Add( arr: array of const ); overload; 
        property Items[Index: String]: TPdfObject read GetItems write SetItems; default; 
    end; 
 
    TPdfStream = class(TPdfDictionary) 
    private 
        FStream: TStringStream; 
    public 
        constructor Create; overload; 
        constructor Create( typ: String ); overload; 
        constructor Create( arr: array of const ); overload; 
        destructor Destroy; override; 
        procedure Print; override; 
        procedure PrintFull; override; 
        procedure Write( str: String ); 
        procedure WriteFmt( str: String; args: array of const ); 
    end; 
 
    TPdfImage = class(TPdfStream) 
    private 
        FGraphic: TGraphic; 
    public 
        constructor Create( _Image: TGraphic ); 
        property Graphic: TGraphic read FGraphic; 
    end; 
 
    TPdfJpeg = class(TPdfImage) 
    public 
        constructor Create( _Image: TJpegImage ); 
    end; 
 
    TPdfBitmap = class(TPdfImage) 
    public 
        constructor Create( _Image: TGraphic ); 
    end; 
 
    TPdfPage = class(TPdfStream) 
    private 
        FMetaObjects: THashInt; 
        FMetaRect: TRect; 
        FMetaFrame: TRect; 
        FMetaExt: TPoint; 
        FMetaPolyFillMode: Integer; 
 
        FWords: TObjectList; 
        FCurFillColor: Integer; 
        FCurStrokeColor: Integer; 
        FCurLineWidth: Integer; 
        FPageSize: TPoint; 
    public 
        constructor Create( _PageSize: TPoint ); 
        destructor Destroy; override; 
        procedure AddWordW( Word: WideString; x,y: Integer ); 
        procedure AddWord( Word: String; x,y: Integer ); 
        procedure WriteMetaFile( x,y,width,height: Integer; emf: HENHMETAFILE ); 
        procedure ProcessMetaRecord( dc: HDC; ht: THandleTable; rec: PEnhMetaRecord; nobj: Integer ); 
        procedure WriteLine( left,top,width,height: Integer ); 
        procedure WriteRect( left,top,width,height: Integer ); 
        procedure WriteFillRect( left,top,width,height: Integer ); 
        procedure WriteFillColor( color: Integer ); 
        procedure WriteStrokeColor( color: Integer ); 
        procedure WriteLineWidth( width: Integer ); 
        procedure WriteImage( left,top,width,height: Integer; graphic: TGraphic; raster: Boolean ); 
        property PageHeight: Integer read FPageSize.y; 
        property PageWidth: Integer read FPageSize.x; 
    end; 
 
    TPdfContext = class 
    private 
        FStream: TStream; 
        FObjects: TObjectList; 
        FIndirects: TObjectList; 
        FCatalog: TPdfDictionary; 
        FDocInfo: TPdfDictionary; 
        FPageTree: TPdfDictionary; 
        FPages: TPdfArray; 
        FXObjects: TPdfArray; 
        FTrailer: TPdfDictionary; 
        FCrypt: TPdfDictionary; 
        FCurPage: TPdfDictionary; 
        FCurContent: TPdfPage; 
        FPageSize: TPoint; 
        FCurFontHeight: Integer; 
        FCurTextColor: Integer; 
        FLinks: TStringList; 
        FEncryptKey: String; 
        function GetLinkData( Name: String ): TPdfArray; 
    public 
        constructor Create( stream: TStream; width, height: Integer; KeyLength: Integer; ACL: Integer; OwnerPassword,UserPassword: String ); 
        destructor Destroy; override; 
        procedure SetDocInfo( Producer,Creator,Title,Author,Subject,Keywords: String ); 
        procedure SetLink( Link: String; Bounds: TRect ); 
        procedure ResolveLink( Link: String; x,y: Integer ); 
        procedure AddContentsLink( Title, Link: String; Level: Integer = 0 ); 
        procedure AddObj( obj: TObject ); 
        function  AddRef( obj: TObject ): Integer; 
        procedure Write( value: String ); 
        procedure Writeln( value: String ); 
        procedure SetFont( Family: String; Height: Integer; Bold, Italic: Boolean ); 
        function  AddPage: TPdfPage; 
        property  Page: TPdfPage read FCurContent; 
        function  StringWidth( str: WideString ): Integer; 
        function  BaseLineShift: Integer; 
        procedure Generate( AEmbedded: Boolean ); 
        property  CurTextColor: Integer read FCurTextColor write FCurTextColor; 
        property PageHeight: Integer read FPageSize.y; 
        property PageWidth: Integer read FPageSize.x; 
    end; 
 
procedure _debug( const str: string; const prm: array of const ); 
 
var 
    PdfContext: TPdfContext; 
    debug: procedure( const str: string; const prm: array of const ) = _debug; 
 
implementation 
 
uses SysUtils, ExtCtrls, ZlibPas, ComObj, QPDFSecurity; 
 
const 
    EOL = #10; 
 
procedure _debug( const str: string; const prm: array of const ); 
begin 
end; 
 
function IntToStrZero( const Value, Digits: Integer ): String; 
begin 
    Result := IntToStr( Value ); 
    if Length(Result) < Digits then 
        Result := StringOfChar( '0', Digits-Length(Result) ) + Result; 
end; 
 
{ TPdfContext } 
 
constructor TPdfContext.Create(stream: TStream; width,height: Integer; KeyLength: Integer; ACL: Integer; OwnerPassword,UserPassword: String ); 
var 
    ID, O, U: String; 
    V: Integer; 
begin 
    PdfContext := Self; 
    FStream := stream; 
    FObjects := TObjectList.Create; 
    FIndirects := TObjectList.Create; 
    FIndirects.OwnsObjects := False; 
    FLinks := TStringList.Create; 
    FLinks.Sorted := True; 
    FLinks.Duplicates := dupError; 
    fontManager.Reset; 
    FPages := TPdfArray.Create; 
    FXObjects := TPdfArray.Create; 
    FPageTree := TPdfDictionary.Create( ['Type','Pages', 'Kids',FPages] ); 
    FCatalog := TPdfDictionary.Create( ['Type','Catalog', 'Pages',FPageTree, 'ViewerPreferences', TPdfDictionary.Create(['FitWindow','true'])] ); 
    FDocInfo := TPdfDictionary.Create; 
    id := CreateClassID; 
    FTrailer := TPdfDictionary.Create( ['Root',FCatalog,'Info',FDocInfo,'ID',TPdfArray.Create(['('+ID,'(0000'] )] ); 
    FCatalog.GetRef; 
    FDocInfo.GetRef; 
    if KeyLength <> 0 then begin 
        KeyLength := KeyLength div 8; 
        if KeyLength < 5 then KeyLength :=5; 
        if KeyLength > 16 then KeyLength := 16; 
        V := 1; if KeyLength > 5 then V := 2; 
        CalculateKeys( OwnerPassword, UserPassword, id, ACL, KeyLength, O, U, FEncryptKey, V+1 ); 
        FCrypt := TPdfDictionary.Create( ['Filter','Standard', 'V',V, 'Length',KeyLength*8, 'R',V+1, 'P',ACL, 'O','('+O, 'U','('+U] ); 
        FCrypt.GetRef; 
        FTrailer.Add( 'Encrypt', FCrypt ); 
        end; 
    FPageSize.x := width; 
    FPageSize.y := height; 
 
end; 
 
destructor TPdfContext.Destroy; 
begin 
    FObjects.Free; 
    FIndirects.Free; 
    FLinks.Free; 
    inherited; 
end; 
 
procedure TPdfContext.AddObj(obj: TObject); 
begin 
    FObjects.Add( obj ); 
end; 
 
function TPdfContext.AddRef(obj: TObject): Integer; 
begin 
    Result := FIndirects.IndexOf( obj ) + 1; 
    if Result = 0 then 
        Result := FIndirects.Add( obj ) + 1; 
end; 
 
procedure TPdfContext.Write(value: String); 
begin 
    if value <> '' then 
        FStream.Write( value[1], Length(value) ); 
end; 
 
procedure TPdfContext.Writeln(value: String); 
begin 
    Write( value ); 
    Write( EOL ); 
end; 
 
type 
    TPdfWord = class 
    public 
        FWord: WideString; 
        Font: TLogicalFont; 
        Height, Width: Integer; 
        Color: Integer; 
        x,y: Integer; 
        FBaseLineShift: Integer; 
    end; 
 
    TPdfWordState = class 
    public 
        data: String; 
        constructor Create( str: String; args: array of const ); 
    end; 
 
constructor TPdfWordState.Create( str: String; args: array of const ); 
var 
    save: Char; 
begin 
    save := DecimalSeparator; 
    DecimalSeparator := '.'; 
    data := Format( str, args ); 
    DecimalSeparator := save; 
end; 
 
 
procedure TPdfContext.Generate( AEmbedded: Boolean ); 
var 
    i,j,k,l,m,y: Integer; 
    bmp: TBitmap; 
    rgn, rgn2: HRGN; 
    rgndata: PRgnData; 
    rects : PRect; 
    p: PByte; 
    o: TPdfObject; 
    xrefs, s: String; 
    page: TPdfPage; 
    word: TPdfWord; 
    wstate: TPdfWordState; 
    curx, cury: Double; 
    curFontIdx, curFontSubIdx, curFontHeight, curOffs1000: Integer; 
    curOffs: Double; 
    wchar, fchar, width: Integer; 
    prepared: String; 
    desc: TPdfDictionary; 
    font: TPdfDictionary; 
    procs: TPdfDictionary; 
    procstr: TPdfStream; 
    Widths: THashInt; 
    Post: TStringList; 
    FontName, FontBody: String; 
    w: TPdfArray; 
    body: TPdfStream; 
    NumFonts: Integer; 
    log: TLogicalFont; 
    fontRes: TPdfDictionary; 
    xobjRes: TPdfDictionary; 
    ToUnicode: TPdfStream; 
    a: TPdfArray; 
 
procedure OutStr; 
var 
    i, j: Integer; 
    forceItalic, forceBold: Boolean; 
    delta: Double; 
begin 
    forceItalic := (AEmbedded or (word.Font.PhysFont.FontType = RASTER_FONTTYPE)) and ((word.Font.Style and 2) <> 0) and ((word.Font.PhysFont.Style and 2) = 0); 
    forceBold :=   (AEmbedded or (word.Font.PhysFont.FontType = RASTER_FONTTYPE)) and ((word.Font.Style and 1) <> 0) and ((word.Font.PhysFont.Style and 1) = 0); 
    if forceItalic then 
        page.WriteFmt( ' 1 0 0.2 -1 %.2f %.2f Tm', [(word.x+curOffs)/100, -y/100] ); 
    page.WriteFillColor( word.Color ); 
    delta := curFontHeight / 100; 
    for j := 1 to 4 do begin 
        page.Write( '<' ); 
        for i := 1 to Length(prepared) do 
            page.Write( IntToHex(Ord(prepared[i]),2) ); 
        page.Write( '>Tj' ); 
        if not forceBold then break; 
        case j of 
            1: page.WriteFmt( ' %.3f 0 Td', [delta] ); 
            2: page.WriteFmt( ' 0 %.3f Td', [delta] ); 
            3: page.WriteFmt( ' %.3f 0 Td', [-delta] ); 
            end; 
        end; 
    if forceItalic or forceBold then 
        page.WriteFmt( ' 1 0 0 -1 %.2f %.2f Tm', [(word.x+curOffs)/100, -y/100] ); 
end; 
 
function CountContents( p: TPdfDictionary ): Integer; 
var 
    i: Integer; 
begin 
    Result := 0; 
    if Assigned(p) then begin 
        i := CountContents( p['First'] as TPdfDictionary ); 
        if i > 0 then p.Add( ['Count', i] ); 
        Result := 1; 
        while Assigned(p['Next']) do begin 
            Inc(Result); 
            p := p['Next'] as TPdfDictionary; 
            end; 
        end; 
end; 
 
 
begin 
    FStream.Position := 0; 
    FStream.Size := 0; 
    FPageTree.Add( ['Count',FPages.Count] ); 
{ 
    AddContentsLink( 'Title', 'Link' ); 
    AddContentsLink( 'Title 2', 'Link2' ); 
    AddContentsLink( 'Title 3', 'Link2', 1 ); 
    AddContentsLink( 'Title 4', 'Link2', 1 ); 
    AddContentsLink( 'Title 4', 'Link2', 2 ); 
    AddContentsLink( 'Title 5', 'Link2', 2 ); 
    AddContentsLink( 'Title 6', 'Link2', 1 ); 
    AddContentsLink( 'Title 7', 'Link2', 2 ); 
    AddContentsLink( 'Title 8', 'Link2', 0 ); 
} 
    CountContents( FCatalog['Outlines'] as TPdfDictionary ); 
 
    // Resolve Fonts 
 
    Post := TStringList.Create; 
    Widths := THashInt.Create; 
    try 
        if AEmbedded then 
            numFonts := fontManager.PrepareForEmbedding 
        else 
            numFonts := fontManager.PrepareForNative; 
        fontRes := TPdfDictionary.Create; 
        for i := 0 to Pred(numFonts) do begin 
            log := fontManager.PreparedFont( i ); 
            Post.Clear; 
            Widths.Clear; 
            fontManager.GetSubset( log, FontName, FontBody, Post, Widths ); 
 
            w := TPdfArray.Create; 
            a := TPdfArray.Create( [1] ); 
            for j := 1 to Widths.Count do begin 
                w.Add( [Widths[j]] ); 
                a.Add( [Post[j-1]] ); 
                end; 
            ToUnicode := TPdfStream.Create; 
            ToUnicode.WriteFmt( '/CIDInit /ProcSet findresource begin 12 dict begin begincmap /CIDSystemInfo <<'#10+ 
                                '/Registry (%s+0) /Ordering (T42UV) /Supplement 0 >> def'#10+ 
                                '/CMapName /%s+0 def'#10+ 
                                '1 begincodespacerange <00> <FF> endcodespacerange'#10+ 
                                '%d beginbfrange'#10, [log.InternalName,log.InternalName,log.subsetCount] ); 
            for j := 1 to log.subsetCount do 
                ToUnicode.WriteFmt( '<%s> <%s> <%s>'#10, [IntToHex(j,2),IntToHex(j,2),IntToHex(log.UsedChars.Indexes[log.SubsetFirst+j-1],4)] ); 
            ToUnicode.Write( 'endbfrange'#10'endcmap CMapName currentdict /CMap defineresource pop end end'#10 ); 
            desc := TPdfDictionary.Create( ['Flags',32,'FontBBox',TPdfArray.Create([0,0,0,0])] ); 
            if FontBody <> '' then begin 
                body := TPdfStream.Create; 
                body.Write( FontBody ); 
                desc.Add( 'FontFile2', body ); 
                end; 
 
            font := TPdfDictionary.Create( ['Type','Font', 
                                            'Subtype','TrueType', 
                                            'Name',log.InternalName, 
                                            'BaseFont',FontName, 
                                            'Encoding',TPdfDictionary.Create( ['Type','Encoding', 'Differences',a] ), 
                                            'FontDescriptor', desc, 
                                            'FirstChar',1, 
                                            'LastChar',w.Count, 
                                            'ToUnicode', ToUnicode, 
                                            'Widths',w] ); 
            fontRes.Add( log.InternalName, font ); 
            if log.PhysFont.FontType = RASTER_FONTTYPE then begin 
                procs := TPdfDictionary.Create; 
                font.Add( ['Subtype','Type3', 'CharProcs',procs] ); 
                font.Add( 'FontMatrix', TPdfArray.Create( [0.001,0,0,0.001,0,0] ) ); 
                font.Add( 'FontBBox', TPdfArray.Create( [0, 0, 1000, 1000] ) ); 
 
                bmp := TBitmap.Create; 
                bmp.Width := 200; 
                bmp.Height := 100; 
                bmp.Monochrome := True; 
                bmp.PixelFormat := pf8bit; 
                bmp.Canvas.Font.Name := log.Family; 
                bmp.Canvas.Font.Size := 72; 
                m := -bmp.Canvas.Font.Height; 
                rgn := CreateRectRgn( 0, 0, 0, 0 ); 
                rgn2 := CreateRectRgn( 0, 0, 0, 0 ); 
 
                for j := 0 to Pred(Post.Count) do begin 
                    procstr := TPdfStream.Create; 
                    procs.Add( Post[j], procstr ); 
                    k := Widths[j+1]; 
                    procstr.WriteFmt( '%d 0 0 0 %d 1000 d1', [k,k] ); 
                    bmp.Canvas.FillRect( Rect(0,0,200,100) ); 
                    k := log.UsedChars.Indexes[log.SubsetFirst+j]; 
                    TextOutW( bmp.Canvas.Handle, 0, 0, PWideChar(@k), 1 ); 
//                    bmp.SaveToFile( 'c:\test.bmp' ); 
                    SetRectRgn( rgn, 0, 0, 0, 0 ); 
                    for k := 0 to Pred(m) do begin 
                        p := bmp.ScanLine[k]; 
                        for l := 0 to 199 do begin 
                            if p^ = 0 then begin 
                                SetRectRgn( rgn2, l*1000 div m, k*1000 div m, (l+1)*1000 div m, (k+1)*1000 div m ); 
                                CombineRgn( rgn, rgn, rgn2, RGN_OR ); 
                                end; 
                            Inc(p); 
                            end; 
                        end; 
                    k := GetRegionData( rgn, 0, nil ); 
                    SetLength(s,k); 
                    rgndata := PRgnData(@s[1]); 
                    rects := PRect(@rgndata^.Buffer); 
                    GetRegionData( rgn, k, rgndata ); 
                    for k := 0 to Pred(rgndata^.rdh.nCount) do begin 
                        procstr.WriteFmt( ' %d %d %d %d re', [rects^.Left, (1000-rects^.Bottom), (rects^.Right-rects^.Left), (rects^.Bottom-rects^.Top)] ); 
                        Inc(rects); 
                        end; 
                    procstr.Write( ' f' ); 
                    end; 
 
                bmp.Free; 
                DeleteObject(rgn); 
                DeleteObject(rgn2); 
                end; 
            end; 
        if numFonts > 0 then 
            FPageTree.Add('Resources', TPdfDictionary.Create( ['Font', fontRes ] ) ); 
    finally 
        Post.Free; 
        Widths.Free; 
    end; 
 
    // xobjects 
 
    if FXObjects.Count <> 0 then begin 
        xobjRes := TPdfDictionary.Create; 
        for i := 0 to Pred(FXObjects.Count) do 
            xobjRes.Add( 'X'+IntToStr(i+1), FXObjects[i] ); 
        (FPageTree['Resources'] as TPdfDictionary).Add( 'XObject', xobjRes ); 
        end; 
 
    // resolve words 
 
    FCurTextColor := 0; 
    for i := 0 to Pred(FPages.Count) do begin 
        page := (FPages[i] as TPdfDictionary)['Contents'] as TPdfPage; 
        if page.FWords.Count = 0 then continue; 
        page.Write( ' BT' ); 
        page.Write( ' 1 0 0 -1 0 0 Tm' ); 
        curx := 0; 
        cury := 0; 
        curFontIdx := 0; 
        curFontSubIdx := 0; 
        curFontHeight := 0; 
        prepared := ''; 
 
        for j := 0 to Pred(page.FWords.Count) do begin 
            if page.FWords[j] is TPdfWordState then begin 
                page.Write( ' ET' ); 
                page.Write( (page.FWords[j] as TPdfWordState).data ); 
                page.Write( ' BT 1 0 0 -1 0 0 Tm' ); 
                curx := 0; 
                cury := 0; 
                curFontIdx := 0; 
                curFontSubIdx := 0; 
                curFontHeight := 0; 
                continue; 
                end; 
            word := page.FWords[j] as TPdfWord; 
            log := word.Font; 
            if AEmbedded or (log.PhysFont.FontType = RASTER_FONTTYPE) then 
                log := log.OrigFont; 
            curOffs := 0; 
            curOffs1000 := 0; 
            prepared := ''; 
            y := -(word.y + word.FBaseLineShift*100); 
            for k := 1 to Length(word.FWord) do begin 
                if (word.x+curOffs <> curx) or (y <> cury) then begin 
                  page.WriteFmt( ' %.2f %.2f Td', [(word.x+curOffs-curx)/100, (y-cury)/100] ); 
                    curx := word.x+curOffs; 
                    cury := y; 
                    end; 
                wchar := Ord(word.FWord[k]); 
                fchar := log.UsedChars.IndexOfIndex(wchar); 
                if fchar = -1 then begin 
                    wchar := $20; 
                    fchar := log.UsedChars.IndexOfIndex(wchar); 
                    end; 
                width := log.UsedChars[wchar]; 
                l := fchar div MAXSUBSET; 
//                debug( 'fchar %d %d', [fchar,l] ); 
                if (curFontIdx <> log.InternalIndex) or (curFontSubIdx <> l) or (curFontHeight <> word.height) then begin 
                    curFontIdx := log.InternalIndex; 
                    curFontSubIdx := l; 
                    curFontHeight := word.height; 
                    s := ''; 
                    if curFontSubIdx > 0 then 
                        s := '-'+IntToStr(curFontSubIdx+1); 
                    if prepared <> '' then begin 
                        OutStr; 
                        prepared := ''; 
                        CurOffs := word.height * CurOffs1000 div 10; 
                        end; 
                    page.WriteFmt( '/F%d%s %d Tf', [curFontIdx,s,curFontHeight] ); 
                    end; 
                prepared := prepared + Chr(fchar-l*MAXSUBSET+1); 
                Inc(CurOffs1000,width); 
                end; 
            if prepared <> '' then OutStr; 
            end; 
        page.Write( ' ET' ); 
        end; 
 
 
    Writeln( '%PDF-1.0' ); 
    Writeln( '%'#$80#$81#$82#$83 ); 
    i := 0; 
    xrefs := '0000000000 65535 f '+EOL; 
    while i < FIndirects.Count do begin 
        s := '000000000'+IntToStr(FStream.Position); 
        xrefs := xrefs + System.Copy( s, Length(s)-9, 10 ) + ' 00000 n '+EOL; 
        o := FIndirects[i] as TPdfObject; 
        Write( o.GetRef + ' 0 obj ' ); 
        o.PrintFull; 
        Writeln( ' endobj' ); 
        Inc(i); 
        end; 
 
    i := FStream.Position; 
    Writeln( 'xref'+EOL+'0 '+IntToStr(FIndirects.Count+1) ); 
    Write( xrefs ); 
 
    Writeln( 'trailer' ); 
    FTrailer.Add( ['Size', FIndirects.Count+1] ); 
    FTrailer.PrintFull; 
    Writeln( '' ); 
    Writeln( 'startxref' ); 
    Writeln( IntToStr( i ) ); 
    Writeln( '%%EOF' ); 
end; 
 
function TPdfContext.AddPage: TPdfPage; 
begin 
    FCurContent := TPdfPage.Create( FPageSize ); 
    FCurPage := TPdfDictionary.Create(['Type','Page', 'Parent',FPageTree, 'Contents',FCurContent]); 
    FPages.Add( FCurPage ); 
    FCurPage.Add( 'MediaBox', TPdfArray.Create([0,0,FPageSize.x,FPageSize.y]) ); 
    FCurTextColor := 0; 
    Result := FCurContent; 
end; 
 
procedure TPdfContext.SetLink(Link: String; Bounds: TRect); 
var 
    d, rect: TPdfArray; 
    x,a: TPdfDictionary; 
begin 
    rect := TPdfArray.Create( [Bounds.Left,FCurContent.FPageSize.Y-Bounds.Top,Bounds.Right,FCurContent.FPageSize.Y-Bounds.Bottom] ); 
    x := TPdfDictionary.Create( ['Type','Annot', 'Subtype','Link', 'Rect',rect, 'Border',TPdfArray.Create([0,0,0])] ); 
    if System.Copy(Link,1,5) = 'http:' then begin 
        a := TPdfDictionary.Create( ['Type','Action', 'S','URI', 'URI','('+Link] ); 
        x.Add( 'A', a ); 
        end 
    else 
        x.Add( 'Dest', GetLinkData( Link ) ); 
 
    d := FCurPage['Annots'] as TPdfArray; 
    if not Assigned(d) then begin 
        d := TPdfArray.Create; 
        FCurPage.Add( 'Annots', d ); 
        end; 
    d.Add( x ); 
end; 
 
procedure TPdfContext.AddContentsLink( Title, Link: String; Level: Integer ); 
var 
    outlines, item, parent, p: TPdfDictionary; 
begin 
    outlines := FCatalog['Outlines'] as TPdfDictionary; 
    if not Assigned(outlines) then begin 
        outlines := TPdfDictionary.Create( 'Outlines' ); 
        FCatalog.Add( 'Outlines', outlines ); 
        end; 
 
    parent := outlines; 
    while level > 0 do begin 
        Dec(level); 
        p := parent['Last'] as TPdfDictionary; 
        if not Assigned(p) then 
            break; 
        Parent := p; 
        end; 
 
    item := TPdfDictionary.Create( ['Title','('+Title, 'Parent',parent, 'Dest',GetLinkData( Link )] ); 
    if Assigned(parent['First']) then begin 
        p := parent['Last'] as TPdfDictionary; 
        item['Prev'] := p; 
        p['Next'] := Item; 
        end 
    else 
        parent['First'] := item; 
    parent['Last'] := item; 
end; 
 
 
 
procedure TPdfContext.SetFont(Family: String; Height: Integer; Bold, Italic: Boolean); 
begin 
    fontManager.SelectFont( Family, Bold, Italic ); 
    FCurFontHeight := Height; 
end; 
 
 
function TPdfContext.StringWidth(str: WideString): Integer; 
begin 
    Result := FCurFontHeight * fontManager.StringWidth(str) div 1000; 
end; 
 
function TPdfContext.BaseLineShift: Integer; 
begin 
    Result := FCurFontHeight - FCurFontHeight * fontManager.CurrentFont.PhysFont.Descent div 10000; 
end; 
 
function TPdfContext.GetLinkData(Name: String): TPdfArray; 
var 
    i: Integer; 
begin 
    if FLinks.Find( Name, i )  then 
        Result := FLinks.Objects[i] as TPdfArray 
    else begin 
        Result := TPdfArray.Create; 
        FLinks.AddObject( Name, Result ); 
        end; 
end; 
 
procedure TPdfContext.ResolveLink(Link: String; x, y: Integer); 
var 
    a: TPdfArray; 
begin 
    a := GetLinkData( Link ); 
    if a.Count > 0 then Exit; 
    a.Add( [FCurPage, 'XYZ', x, FCurContent.FPageSize.Y - Y, 0] ); 
end; 
 
procedure TPdfContext.SetDocInfo(Producer, Creator, Title, Author, Subject, Keywords: String); 
var 
    tz: TIME_ZONE_INFORMATION; 
    today: String; 
begin 
    GetTimeZoneInformation( tz ); 
    today := '(D:' + FormatDateTime( 'yyyymmddhhnnss', Now ); 
    if tz.Bias < 0 then begin 
        today := today + '+'; 
        tz.Bias := -tz.Bias; 
        end 
    else 
        today := today + '-'; 
    today := today + IntToStrZero( tz.bias div 60, 2 ) + '''' + IntToStrZero( tz.bias mod 60, 2 ) + ''''; 
    FDocInfo.Add( ['Producer','('+Producer,'Creator','('+Creator,'Title','('+Title,'Author','('+Author,'Subject','('+Subject,'Keywords','('+Keywords,'CreationDate',today,'ModDate',today] ); 
end; 
 
{ TPdfObject } 
 
constructor TPdfObject.Create; 
begin 
    if not Assigned( PdfContext ) then 
        Fatal( 'Default pdf context is not specified' ); 
    FContext := PdfContext; 
    FContext.AddObj(Self); 
    FParent := nil; 
end; 
 
constructor TPdfObject.Create(value: String); 
begin 
    Create; 
    if (value[1] <> '(') and (value <> 'true') and (value <> 'false') then 
        value := '/'+value; 
    FStringContent := value; 
end; 
 
constructor TPdfObject.Create(value: Integer); 
begin 
    Create; 
    FStringContent := IntToStr( value ); 
end; 
 
constructor TPdfObject.Create(value: Extended); 
var 
    save: Char; 
begin 
    Create; 
    save := DecimalSeparator; 
    DecimalSeparator := '.'; 
    FStringContent := FloatToStr( value ); 
    DecimalSeparator := save; 
end; 
 
procedure TPdfObject.Fatal(msg: String); 
begin 
    raise Exception.Create( 'Internal error: '+msg ); 
end; 
 
procedure TPdfObject.Print; 
begin 
    if FRefID <> 0 then 
        PrintRef 
    else 
        PrintFull; 
end; 
 
procedure TPdfObject.PrintFull; 
var 
    o: TPdfObject; 
    s: String; 
    i: Integer; 
    bad: Boolean; 
    value: String; 
begin 
    if FStringContent = '' then 
        Fatal( 'Print body was not defined' ); 
    value := FStringContent; 
    if value[1] = '(' then begin 
        Delete( value, 1, 1 ); 
        if FContext.FEncryptKey <> '' then begin 
            o := Self; 
            while Assigned(o) and ((o.FRefID = 0) or (o = FContext.FCrypt)) do 
                o := o.FParent; 
            if Assigned(o) then 
                Value := Encrypt( Value, o.FRefID, FContext.FEncryptKey ) 
            else 
                debug( 'uncr %s', [value] ); 
            end; 
        bad := false; 
        for i := 1 to Length(value) do 
            if (value[i] < ' ') or (value[i] > #$7F) then begin 
                bad := True; 
                break; 
                end; 
        for i := 1 to Length(value) do begin 
            if bad then 
                s := s + IntTohex(ord(value[i]),2) 
            else begin 
                if value[i] in ['(',')','\'] then 
                    s := s + '\'; 
                s := s + value[i]; 
                end; 
            end; 
        if bad then 
            value := '<'+s+'>' 
        else 
            value := '('+s+')'; 
        end; 
    FContext.Write( value ); 
end; 
 
procedure TPdfObject.PrintRef; 
begin 
    FContext.Write( GetRef + ' 0 R' ); 
end; 
 
function TPdfObject.GetRef: String; 
begin 
    if FRefID = 0 then 
        FRefID := FContext.AddRef( Self ); 
    Result := IntToStr(FRefID); 
end; 
 
 
{ TPdfArray } 
 
constructor TPdfArray.Create; 
begin 
    inherited; 
    FArray := TObjectList.Create; 
    FArray.OwnsObjects := False; 
end; 
 
constructor TPdfArray.Create(arr: array of const); 
begin 
    Create; 
    Add( arr ); 
end; 
 
destructor TPdfArray.Destroy; 
begin 
    FArray.Free; 
    inherited; 
end; 
 
procedure TPdfArray.Add(obj: TPdfObject); 
begin 
    FArray.Add( obj ); 
    obj.FParent := Self; 
end; 
 
procedure TPdfArray.Add(arr: array of const); 
var 
    i: Integer; 
begin 
    for i := 0 to High(arr) do with arr[i] do 
        case VType of 
            vtInteger: Add( TPdfObject.Create( VInteger ) ); 
            vtAnsiString: Add( TPdfObject.Create( string(VAnsiString) ) ); 
            vtObject: Add( VObject as TPdfObject ); 
            vtExtended: Add( TPdfObject.Create( VExtended^ ) ) 
            else Fatal( 'Unknown type '+IntToStr(VType)+' in open array' ); 
        end; 
end; 
 
 
procedure TPdfArray.PrintFull; 
var 
    i: Integer; 
begin 
    FContext.Write( '[' ); 
    for i := 0 to Pred(FArray.Count) do begin 
        if i > 0 then FContext.Write( ' ' ); 
        (Farray[i] as TPdfObject).Print; 
        end; 
    FContext.Write( ']' ); 
end; 
 
function TPdfArray.Count: Integer; 
begin 
    Result := FArray.Count; 
end; 
 
function TPdfArray.GetItems(Index: Integer): TPdfObject; 
begin 
    Result := FArray[Index] as TPdfObject; 
end; 
 
 
{ TPdfDictionary } 
 
constructor TPdfDictionary.Create; 
begin 
    inherited; 
    FDict := TStringList.Create; 
end; 
 
constructor TPdfDictionary.Create(arr: array of const); 
begin 
    Create; 
    Add( arr ); 
end; 
 
constructor TPdfDictionary.Create(typ: String); 
begin 
    Create; 
    Add( 'Type', TPdfObject.Create( typ ) ); 
end; 
 
destructor TPdfDictionary.Destroy; 
begin 
    FDict.Free; 
    inherited; 
end; 
 
procedure TPdfDictionary.Add(name: String; obj: TPdfObject); 
var 
    i: Integer; 
begin 
    obj.FParent := Self; 
    if Find( name, i ) then 
        FDict.Objects[i] := obj 
    else 
        FDict.AddObject( name, obj ); 
end; 
 
 
procedure TPdfDictionary.Add(arr: array of const); 
var 
    i: Integer; 
    name: String; 
begin 
    i := 0; 
    while i < High(arr) do begin 
        if arr[i].VType = vtAnsiString then 
            name := string(arr[i].VAnsiString) 
        else if arr[i].VType = vtChar then 
            name := string(arr[i].VChar) 
        else 
            Fatal( 'Wrong sequence of dictionary params' ); 
        with arr[i+1] do case VType of 
            vtInteger: Add( name, TPdfObject.Create( VInteger ) ); 
            vtAnsiString: Add( name, TPdfObject.Create( string(VAnsiString) ) ); 
            vtObject: Add( name, VObject as TPdfObject ); 
            else Fatal( 'Unknown type '+IntToStr(VType)+' in dictionary open array' ); 
            end; 
        Inc(i,2); 
        end; 
end; 
 
procedure TPdfDictionary.Print; 
var 
    i: Integer; 
begin 
    if Find( 'Type', i ) or Find( 'Parent', i ) then PrintRef else inherited; 
 
end; 
 
procedure TPdfDictionary.PrintFull; 
var 
    i: Integer; 
begin 
    FContext.Write( '<<' ); 
    for i := 0 to Pred(FDict.Count) do begin 
        if i > 0 then FContext.Write( ' ' ); 
        FContext.Write( '/'+FDict[i]+' ' ); 
        (FDict.Objects[i] as TPdfObject).Print; 
        end; 
    FContext.Write( '>>' ); 
end; 
 
function TPdfDictionary.GetItems(Index: String): TPdfObject; 
var 
    i: Integer; 
begin 
    Result := nil; 
    if Find( Index, i ) then 
        Result := FDict.Objects[i] as TPdfObject; 
end; 
 
procedure TPdfDictionary.SetItems(Index: String; const Value: TPdfObject); 
begin 
    Add( Index, Value ); 
end; 
 
function TPdfDictionary.Find(name: String; var Index: Integer): Boolean; 
var 
    i: Integer; 
begin 
    for i := 0 to Pred(FDict.Count) do 
        if FDict[i] = name then begin 
            Index := i; 
            Result := True; 
            Exit; 
            end; 
    Result := False; 
end; 
 
{ TPdfStream } 
 
constructor TPdfStream.Create; 
begin 
    inherited; 
    FStream := TStringStream.Create(''); 
end; 
 
constructor TPdfStream.Create(typ: String); 
begin 
    inherited; 
    FStream := TStringStream.Create(''); 
end; 
 
constructor TPdfStream.Create(arr: array of const); 
begin 
    inherited; 
    FStream := TStringStream.Create(''); 
end; 
 
destructor TPdfStream.Destroy; 
begin 
    FStream.Free; 
    inherited; 
end; 
 
procedure TPdfStream.Print; 
begin 
    PrintRef; 
end; 
 
function CompressStr( inStr: String ): String; 
var 
    strm: z_stream; 
    inBytes,outBytes: Integer; 
 
function Check(code: Integer): Integer; 
begin 
    Result := code; 
    if (code < 0) then 
        raise Exception.Create( 'Compression error' ); 
end; 
 
begin 
    inBytes := Length(inStr); 
    outBytes := ((inBytes + (inBytes div 10) + 12) + 255) and not 255; 
    SetLength( Result, outBytes ); 
    FillChar(strm, sizeof(strm), 0); 
    strm.next_in := @inStr[1]; 
    strm.avail_in := inBytes; 
    strm.next_out := @Result[1]; 
    strm.avail_out := outBytes; 
    Check(deflateInit(strm, 9)); 
    try 
        while Check(deflate(strm, Z_FINISH)) <> Z_STREAM_END do begin 
            Inc(outBytes, 256); 
            SetLength( Result, outBytes ); 
            strm.next_out := @Result[strm.total_out+1]; 
            strm.avail_out := 256; 
            end; 
    finally 
        Check(deflateEnd(strm)); 
    end; 
    SetLength( Result, strm.total_out ); 
end; 
 
 
procedure TPdfStream.PrintFull; 
var 
    Data: String; 
begin 
    if not Assigned(Items['Filter']) then begin 
        Data := CompressStr( FStream.DataString ); 
        if Length(Data)+20 > Length(FStream.DataString) then 
            Data := FStream.DataString 
        else 
            Add( ['Length1',Length(FStream.DataString), 'Filter','FlateDecode'] ); 
        end 
    else 
        Data := FStream.DataString; 
    if FContext.FEncryptKey <> '' then begin 
        Data := Encrypt( Data, FRefID, FContext.FEncryptKey ); 
        end; 
    Add( ['Length', Length(Data)] ); 
    inherited; 
    FContext.Writeln( ' stream' ); 
    FContext.Write( Data ); 
    FContext.Write( 'endstream' ); 
end; 
 
procedure TPdfStream.Write(str: String); 
begin 
    FStream.Write( str[1], Length(str) ); 
end; 
 
procedure TPdfStream.WriteFmt(str: String; args: array of const); 
var 
    save: Char; 
begin 
    save := DecimalSeparator; 
    DecimalSeparator := '.'; 
    Write( Format( str, args ) ); 
    DecimalSeparator := save; 
end; 
 
{ TPdfPage } 
 
procedure TPdfPage.AddWord(Word: String; x, y: Integer); 
begin 
    AddWordW( Word, x, y ); 
end; 
 
procedure TPdfPage.AddWordW(Word: WideString; x, y: Integer); 
var 
    w: TPdfWord; 
begin 
    w := TPdfWord.Create; 
    w.FWord := Word; 
    w.Font := fontManager.CurrentFont; 
    w.x := x; 
    w.y := y; 
    w.height := FContext.FCurFontHeight; 
    w.width := fontManager.StringWidthW( Word ); 
    w.Color := FContext.FCurTextColor; 
    w.FBaseLineShift := Context.BaseLineShift; 
    FWords.Add( w ); 
end; 
 
constructor TPdfPage.Create( _PageSize: TPoint ); 
begin 
    inherited Create; 
    FWords := TObjectList.Create; 
    FCurFillColor := 0; 
    FCurStrokeColor := 0; 
    FCurLineWidth := 0; 
    FPageSize := _PageSize; 
    WriteFmt( '1 0 0 -1 0 %d cm', [FPageSize.y] ); 
end; 
 
destructor TPdfPage.Destroy; 
begin 
    Inherited; 
    FWords.Free; 
end; 
 
function EnumProc( dc: HDC; ht: PHANDLETABLE; rec: PENHMETARECORD; nobj: Integer; ctx: TPdfPage ): BOOL; stdcall; 
begin 
    ctx.ProcessMetaRecord( dc, ht^, rec, nobj ); 
    Result := rec^.iType <> EMR_EOF; 
end; 
 
procedure TPdfPage.WriteMetaFile(x,y,width,height: Integer; emf: HENHMETAFILE); 
var 
    DC: HDC; 
    I: Integer; 
begin 
    FMetaObjects := THashInt.Create; 
    FMetaPolyFillMode := WINDING; 
    WriteFillColor( $FFFFFF ); 
    WriteStrokeColor( 0 ); 
    WriteLineWidth( 0 ); 
    DC := CreateCompatibleDC( 0 ); 
    FMetaRect := Rect(x,y,x+width,y+height); 
    Write( ' q 2 j' ); 
    FWords.Add( TPdfWordState.Create( ' q', [] ) ); 
    EnumEnhMetaFile( 0, emf, @EnumProc, Self, FMetaRect ); 
    Write( ' Q' ); 
    FWords.Add( TPdfWordState.Create( ' Q', [] ) ); 
    DeleteDC( DC ); 
    for i := 0 to Pred(FMetaObjects.Count ) do 
        TObject(FMetaObjects[FMetaObjects.Indexes[i]]).Free; 
    FMetaObjects.Free; 
end; 
 
type 
    TMetaFont = class 
        Family: String; 
        Bold: Boolean; 
        Italic: Boolean; 
        Height: Integer; 
        end; 
    TMetaPen = class 
        Style,Width,Color: Integer; 
        constructor Create( _Style, _Width, _Color: Integer ); 
        end; 
    TMetaBrush = class 
        Style,Hatch,Color: Integer; 
        constructor Create( _Style, _Hatch, _Color: Integer ); 
        end; 
 
constructor TMEtaPen.Create( _Style, _Width, _Color: Integer ); 
begin 
    inherited Create; 
    Style := _Style; 
    Width := _Width; 
    Color := _Color; 
end; 
 
constructor TMetaBrush.Create(_Style, _Hatch, _Color: Integer); 
begin 
    inherited Create; 
    Style := _Style; 
    Hatch := _Hatch; 
    Color := _Color; 
end; 
 
procedure TPdfPage.ProcessMetaRecord(dc: HDC; ht: THandleTable; rec: PEnhMetaRecord; nobj: Integer); 
var 
    wstate: TPdfWordState; 
    fnt: TMetaFont; 
    p: PChar; 
    ws: WideString; 
    obj: TObject; 
    tm: TEXTMETRIC; 
    saveFont: HFONT; 
    i, j: Integer; 
    fx, fy, fx2, fy2: Extended; 
    xdc: HDC; 
    pp: PSmallPoint; 
begin 
    case rec^.iType of 
        EMR_HEADER: 
            with PEnhMetaHeader(rec)^ do begin 
                FMetaFrame := rclFrame; 
{ 
                debug( 'my frame [%d %d %d %d]', [FMetaRect.Left,FMetaRect.Top,FMetaRect.Right,FMetaRect.Bottom] ); 
                debug( 'meta frame [%d %d %d %d]', [rclframe.left, rclframe.top, rclframe.right-rclframe.left, rclframe.bottom-rclframe.top] ); 
                debug( 'meta bounds [%d %d %d %d]', [rclbounds.left, rclbounds.top, rclbounds.right-rclbounds.left, rclbounds.bottom-rclbounds.top] ); 
                debug( 'meta szl [%d %d]', [szlDevice.cx,szlDevice.cy] ); 
                debug( 'meta szlmm [%d %d]', [szlMillimeters.cx,szlMillimeters.cy] ); 
} 
                fx := szlMillimeters.cx * 100 / szlDevice.cx; 
                fy := szlMillimeters.cy * 100 / szlDevice.cy;   // logical -> frame 
                fx2 := (FMetaRect.Right - FMetaRect.Left - 1) / (rclFrame.Right - rclFrame.Left); // frame -> pdf 
                fy2 := (FMetaRect.Bottom - FMetaRect.Top - 1) / (rclFrame.Bottom - rclFrame.Top); 
                wstate := TPdfWordState.Create( ' %.5f 0 0 %.5f %.3f %.3f cm', [fx*fx2, fy*fy2, FMetaRect.Left-rclFrame.Left*fx2+0.5, FMetaRect.Top-rclFrame.Top*fy2+0.5] ); 
                Write( wstate.data ); 
                FWords.Add( wstate ); 
//                debug( ' %.5f 0 0 %.5f %.3f %.3f cm', [fx*fx2, fy*fy2, FMetaRect.Left-rclFrame.Left*fx2, FMetaRect.Top-rclFrame.Top*fy2] ); 
//                FMetaLogWidth := fx*fx2; 
//                FMetaLogHeight 
                end; 
                { 
                debug( 'meta frame [%d %d %d %d]', [rclframe.left, rclframe.top, rclframe.right-rclframe.left, rclframe.bottom-rclframe.top] ); 
                debug( 'meta bounds [%d %d %d %d]', [rclbounds.left, rclbounds.top, rclbounds.right-rclbounds.left, rclbounds.bottom-rclbounds.top] ); 
                debug( 'meta szl [%d %d]', [szlDevice.cx,szlDevice.cy] ); 
                debug( 'meta szlmm [%d %d]', [szlMillimeters.cx,szlMillimeters.cy] ); 
                fx := (FMetaRect.Right - FMetaRect.Left) / (rclFrame.Right - rclFrame.Left); 
                fy := (FMetaRect.Bottom - FMetaRect.Top) / (rclFrame.Bottom - rclFrame.Top); 
                debug( 'scale %.3f %.3f', [fx, fy] ); 
                WriteFmt( ' %d %d m %d %d l S', [FMetaRect.Left,FMetaRect.Top,FMetaRect.right, FMetaRect.bottom] ); 
                WriteFmt( ' q %.5f 0 0 %.5f %.3f %.3f cm', [fx, fy, FMetaRect.Left-rclFrame.Left*fx, FMetaRect.Top-rclFrame.Top*fy] ); 
                debug( ' q %.3f 0 0 %.3f %.3f %.3f cm', [fx, fy, FMetaRect.Left-rclFrame.Left*fx, FMetaRect.Right-rclFrame.Top*fy] ); 
                WriteFmt( ' %d %d m %d %d l S', [rclFrame.Left,rclFrame.Top,rclframe.right, rclframe.bottom] ); 
                WriteFmt( ' %d %d m %d %d l S', [0,0,1581,-1518] ); 
                end; 
        EMR_EOF: 
            Write( ' Q' ); 
}                         + 
        EMR_SELECTOBJECT: begin 
            i := PEMRSelectObject(rec)^.ihObject; 
//            debug( 'select %X', [i] ); 
            obj := TObject(FMetaObjects[i]); 
            if obj is TMetaFont then with TMetaFont(obj) do begin 
                FContext.SetFont( Family, Height, Bold, Italic ); 
//                debug( 'Select font %s/%d (%d)', [Family,Height,i] ); 
                end 
            else if obj is TMetaPen then with TMetaPen(obj) do begin 
                WriteLineWidth( Width ); 
                WriteStrokeColor( Color ); 
//                debug( 'Select pen %d %d %d', [Style,Width,Color] ); 
                end 
            else if obj is TMetaBrush then with TMetaBrush(obj) do begin 
                WriteFillColor( Color ); 
//                debug( 'Select brush %d %d %X', [Style,Hatch,Color] ); 
                end 
            {else 
                debug( 'Select object %X', [i] );} 
            end; 
        EMR_DELETEOBJECT: begin 
            i := PEMRDeleteObject(rec)^.ihObject; 
//            debug( 'delete %X', [i] ); 
            obj := TObject(FMetaObjects[i]); 
            if obj is TMetaBrush then begin 
                WriteFillColor( $FFFFFF ); 
//                debug( 'delete brush', [] ); 
                end 
            else 
                {debug( 'Select object %X', [i] )}; 
            end; 
        EMR_EXTCREATEFONTINDIRECTW: begin 
            fnt := TMetaFont.Create; 
            with PEMRExtCreateFontIndirect(rec)^.elfw.elfLogFont do begin 
                i := lfHeight; 
                if i < 0 then 
                    i := -i// * 72 div GetDeviceCaps(dc, LOGPIXELSY) * 1000 div 780 
                else begin 
                    xdc := CreateCompatibleDC(0); 
                    saveFont := SelectObject( xdc, CreateFontIndirectW( PEMRExtCreateFontIndirect(rec)^.elfw.elfLogFont ) ); 
                    GetTextMetrics( xdc, tm ); 
                    i := tm.tmHeight - tm.tmInternalLeading; 
                    DeleteObject( SelectObject( xdc, saveFont ) ); 
                    DeleteDC( xdc ); 
                    end; 
 
                fnt.Height := i; 
                fnt.Family := lfFaceName; 
                fnt.Bold := lfHeight > 600; 
                fnt.Italic := lfItalic <> 0; 
//                debug( 'Create font %s/%d (%d)', [lfFaceName, i, lfHeight] ); 
                end; 
            i := PEMRExtCreateFontIndirect(rec)^.ihFont; 
            if FMetaObjects[i] <> 0 then TObject(FMetaObjects[i]).Free; 
            FMetaObjects[i] := Integer(fnt); 
            end; 
        EMR_CREATEPEN: 
            with PEMRCreatePen(rec)^ do begin 
                if FMetaObjects[ihPen] <> 0 then TObject(FMetaObjects[ihPen]).Free; 
                FMetaObjects[ihPen] := Integer(TMetaPen.Create(lopn.lopnStyle,lopn.lopnWidth.x,lopn.lopnColor)); 
//                debug( 'create pen %d [%d %d %d]', [ihPen,lopn.lopnStyle,lopn.lopnWidth.x,lopn.lopnColor] ); 
                end; 
        EMR_CREATEBRUSHINDIRECT: 
            with PEMRCreateBrushIndirect(rec)^ do begin 
                if FMetaObjects[ihBrush] <> 0 then TObject(FMetaObjects[ihBrush]).Free; 
                FMetaObjects[ihBrush] := Integer(TMetaBrush.Create(lb.lbStyle,lb.lbHatch,lb.lbColor)); 
//                debug( 'create brush %d [%d %d %d]', [ihBrush,lb.lbStyle,lb.lbHatch,lb.lbColor] ); 
                end; 
 
 
        EMR_MOVETOEX: 
            with PEmrMoveToEx(rec)^ do begin 
//                debug( 'moveto %d,%d', [ptl.x, ptl.y] ); 
                WriteFmt( ' %d %d m', [ptl.x, ptl.y] ); 
                end; 
        EMR_LINETO: 
            with PEmrLineTo(rec)^ do begin 
//                debug( 'lineto %d,%d', [ptl.x, ptl.y] ); 
                WriteFmt( ' %d %d l s', [ptl.x, ptl.y] ); 
                end; 
        EMR_POLYBEZIERTO16: 
            with PEmrPolyBezierTo16(rec)^ do begin 
//                debug( 'bezier %d pts', [cpts] ); 
                for i := 0 to Pred(cpts div 3) do begin 
                    for j := 0 to 2 do 
                        WriteFmt( ' %d %d', [apts[i*3+j].x, apts[i*3+j].y] ); 
                    Write( ' c' ); 
                    end; 
                end; 
        EMR_POLYGON16: 
            with PEmrPolygon16(rec)^ do begin 
//                if first then begin first := false; exit; end; 
//                debug( 'poly16 %d %X', [cpts, FCurFillColor] ); 
                pp := PSmallPoint(@apts); 
                WriteFmt( ' %d %d m', [pp^.x,pp^.y] ); 
                for i := 0 to cpts-2 do begin 
                    Inc(pp); 
                    WriteFmt( ' %d %d l', [pp^.x,pp^.y] ); 
                    end; 
                if FMetaPolyFillMode = ALTERNATE then 
                    Write( ' f*' ) 
                else 
                    Write( ' b' ) 
                end; 
        EMR_POLYPOLYGON16, EMR_POLYPOLYLINE16: 
            with PEmrPolyPolygon16(rec)^ do begin 
                pp := PSmallPoint(@aPolyCounts[nPolys]); 
                for i := 0 to Pred(nPolys) do begin 
                    WriteFmt( ' %d %d m', [pp^.x, pp^.y] ); 
                    Inc(pp); 
                    for j := 1 to Pred( aPolyCounts[i] ) do begin 
                        WriteFmt( ' %d %d l', [pp^.x, pp^.y] ); 
                        Inc(pp); 
                        end; 
                    end; 
 
                if rec^.iType = EMR_POLYPOLYLINE then 
                    Write( ' s' ) 
                else if FMetaPolyFillMode = ALTERNATE then 
                    Write( ' f*' ) 
                else 
                    Write( ' f' ); 
                end; 
        EMR_CLOSEFIGURE: begin 
//            debug( 'close figure', [] ); 
            Write( ' h' ); 
            end; 
        EMR_SETPOLYFILLMODE: 
            with PEMRSetPolyFillMode(rec)^ do 
                FMetaPolyFillMode := iMode; 
        EMR_FILLPATH: begin 
//            debug( 'fill path', [] ); 
            if FMetaPolyFillMode = ALTERNATE then 
                Write( ' f*' ) 
            else 
                Write( ' f' ); 
            end; 
        EMR_BEGINPATH, EMR_ENDPATH: ; 
 
        EMR_EXTTEXTOUTW: begin 
            with PEMRExtTextOut(rec)^ do begin 
                p := PChar(rec); 
                Inc(p,emrtext.offString); 
                SetLength( ws, emrtext.nChars ); 
                for i := 1 to emrtext.nChars do begin 
                    ws[i] := PWideChar(p)^; 
                    Inc(p,2) 
                    end; 
//                debug( 'textout [%d %d %d %d] scale [%f %f] ref [%d %d] %s %d %d %d', [rclbounds.left,rclbounds.top,rclbounds.right,rclbounds.bottom,exScale,exScale,emrtext.ptlReference.x,emrtext.ptlReference.y,ws,emrtext.nChars,emrtext.offString,emrText.offDx] ); 
 
//                i := fontManager.StringWidthW( ws ); 
//                debug( 'actual width %d %d', [i,i*FContext.FCurFontHeight div 1000] ); 
 
//                AddWordW( ws, emrText.ptlReference.x*100, emrText.ptlReference.y*100 ); 
                AddWordW( ws, rclBounds.left * 100, rclBounds.Top * 100 ); 
                end; 
//                    debug( 'textout %d', [log.lfHeight] ); 
//            debug( '%d', [GetObject( ht.objectHandle[i], 0, nil )] ); 
            end; 
        EMR_SETTEXTCOLOR: begin 
            with PEMRSetTextColor(rec)^ do begin 
                FContext.FCurTextColor := crColor; 
//                debug( 'set color %X', [crColor] ); 
                end; 
            end; 
        EMR_RECTANGLE: begin 
            with PEMRRectangle(rec)^ do begin 
//                debug( 'rectangle [%d %d %d %d]', [rclBox.Left, rclBox.Top, rclBox.Right-rclBox.Left, rclBox.Bottom-rclBox.Top] ); 
                WriteFmt( ' %d %d %d %d re b', [rclBox.Left, rclBox.Top, rclBox.Right-rclBox.Left, rclBox.Bottom-rclBox.Top] ); 
//                WriteRect( rclBox.Left, rclBox.Top, rclBox.Right-rclBox.Left, rclBox.Bottom-rclBox.Top ); 
//                DrawRect( rclBox.Left, rclBox.Top, rclBox.Left+324, rclBox.Top+48 ); 
                end; 
            end; 
        EMR_BITBLT: 
            with PEmrBitBlt(rec)^ do begin 
//                debug( 'bitblt [%d,%d,%d,%d]', [xDest, yDest,cxDest,cyDest] ); 
                WriteFillRect( xDest, yDest, cxDest, cyDest ); 
                end; 
        EMR_SETMAPMODE: 
            with PEmrSetMapMode(rec)^ do begin 
//                debug( 'map mode %d', [iMode] ); 
                end; 
        EMR_SETWINDOWORGEX: 
            with PEMRSetWindowOrgEx(rec)^ do begin 
//                debug( 'set org %d %d', [ptlOrigin.x, ptlOrigin.y] ); 
                end; 
        EMR_SETVIEWPORTORGEX: 
            with PEMRSetViewportOrgEx(rec)^ do begin 
//                debug( 'set vp org %d %d', [ptlOrigin.x, ptlOrigin.y] ); 
                end; 
        EMR_SETWINDOWEXTEX: 
            with PEMRSetWindowExtEx(rec)^ do begin 
                FMetaExt.x := szlExtent.cx; 
                FMetaExt.y := szlExtent.cy; 
//                debug( 'set ext %d %d', [szlExtent.cx, szlExtent.cy] ); 
                end; 
 
        EMR_SETVIEWPORTEXTEX: 
            with PEMRSetWindowExtEx(rec)^ do begin 
//                debug( 'set vp ext %d %d', [szlExtent.cx, szlExtent.cy] ); 
//                fx := (FMetaRect.Right - FMetaRect.Left) / szlExtent.cx; 
//                fy := (FMetaRect.Bottom - FMetaRect.Top) / szlExtent.cy; 
//                fx2 := szlExtent.cx / (FMetaFrame.Right-FMetaFrame.Left+1); 
//                fy2 := szlExtent.cy / (FMetaFrame.Bottom-FMetaFrame.Top+1); 
                fx := szlExtent.cx / FMetaExt.x; 
                fy := szlExtent.cy / FMetaExt.y; 
                wstate := TPdfWordState.Create( ' %.5f 0 0 %.5f 0 0 cm', [fx, fy] ); 
                Write( wstate.data ); 
                FWords.Add( wstate ); 
//                debug( ' %.5f 0 0 %.5f 0 0 cm', [fx, fy] ); 
//                debug( 'f = %.3f %.3f %.3f %.3f', [fx,fy,fx2,fy2] ); 
//                WriteFmt( ' %d %d m %d %d l s', [FMetaRect.Left,FMetaRect.Top,FMetaRect.Right,FMetaRect.Bottom] ); 
//                WriteFmt( ' Q q %.5f 0 0 %.5f %.3f %.3f cm', [fx, fy, FMetaRect.Left-FMetaFrame.Left*fx*fx2, FMetaRect.Top-FMetaFrame.Top*fy*fy2] ); 
//                debug( ' %.5f 0 0 %.5f %.3f %.3f cm', [fx, fy, FMetaRect.Left-FMetaFrame.Left*fx*fx2, FMetaRect.Top-FMetaFrame.Top*fy*fy2] ); 
//                WriteFmt( ' %.1f %.1f m %.1f %.1f l s', [FMetaFrame.Left*fx2,FMetaFrame.Top*fy2,FMetaFrame.Right*fx2,FMetaFrame.Bottom*fy2] ); 
                end; 
 
        {else 
            debug( 'meta %d %X %d', [rec.iType, rec.nSize, nobj] );} 
        end; 
end; 
 
procedure TPdfPage.WriteFillColor(color: Integer); 
begin 
    color := ColorToRGB( color ); 
    if color = FCurFillColor then Exit; 
    FCurFillColor := color; 
    WriteFmt( ' %1.3f %1.3f %1.3f rg', [(color and 255) / 255, ((color shr 8) and 255) / 255, (color shr 16) / 255] ); 
end; 
 
procedure TPdfPage.WriteStrokeColor(color: Integer); 
begin 
    color := ColorToRGB( color ); 
    if color = FCurStrokeColor then Exit; 
    FCurStrokeColor := color; 
    WriteFmt( ' %1.3f %1.3f %1.3f RG', [(color and 255) / 255, ((color shr 8) and 255) / 255, (color shr 16) / 255] ); 
end; 
 
procedure TPdfPage.WriteRect(left, top, width, height: Integer); 
begin 
    WriteFmt( ' %d %d %d %d re S', [left,top,width,height] ) 
end; 
 
procedure TPdfPage.WriteFillRect(left, top, width, height: Integer); 
begin 
    WriteFmt( ' %d %d %d %d re f', [left,top,width,height] ) 
end; 
 
procedure TPdfPage.WriteLineWidth(width: Integer); 
begin 
    WriteFmt( ' %d w', [width] ); 
end; 
 
procedure TPdfPage.WriteLine(left, top, width, height: Integer); 
begin 
    WriteFmt( ' %d %d m %d %d l S', [left, top, left+width, top+height] ); 
end; 
 
procedure TPdfPage.WriteImage( left,top,width,height: Integer; graphic: TGraphic; raster: Boolean ); 
var 
    i: Integer; 
    idx: Integer; 
begin 
    Idx := 0; 
    for i := 0 to Pred(Context.FXObjects.Count) do 
        if (Context.FXObjects[i] as TPdfImage).FGraphic = graphic then begin 
            Idx := i+1; 
            break; 
            end; 
    if Idx = 0 then begin 
        if (graphic is TJpegImage) and (not raster) then 
            TPdfJpeg.Create( graphic as TJpegImage ) 
        else if (graphic is TMetaFile) and (not raster) then begin 
            WriteMetafile( left, top, width, height, TMetaFile(graphic).Handle ); 
            Exit; 
            end 
        else 
            TPdfBitmap.Create( graphic ); 
        Idx := Context.FXObjects.Count; 
        end; 
    WriteFmt( ' q %d 0 0 %d %d %d cm /X%d Do Q', [width,-height, left, top+height, idx] ); 
end; 
 
{ TPdfImage } 
 
constructor TPdfImage.Create(_Image: TGraphic); 
begin 
    FGraphic := _Image; 
    inherited Create( ['Type','XObject','Subtype','Image', 
                       'Width',_Image.Width,'Height',_Image.Height, 
                       'ColorSpace','DeviceRGB','BitsPerComponent',8] ); 
    Context.FXObjects.Add( Self ); 
    Add( ['Name', 'X'+IntToStr(Context.FXObjects.Count)] ); 
end; 
 
{ TPdfJpeg } 
 
constructor TPdfJpeg.Create( _Image: TJpegImage ); 
begin 
    inherited Create( _Image ); 
    _Image.SaveToStream( FStream ); 
    Add( ['Filter','DCTDecode'] ); 
 
end; 
 
{ TPdfBitmap } 
 
constructor TPdfBitmap.Create( _Image: TGraphic ); 
var 
    img: TImage; 
    i,j: Integer; 
    p: PByte; 
begin 
    inherited Create( _Image ); 
    img := TImage.Create(nil); 
    try 
        img.Picture.Bitmap.PixelFormat := pf24bit; 
        img.Picture.Bitmap.Width := _Image.Width; 
        img.Picture.Bitmap.Height := _Image.Height; 
        img.Canvas.Draw( 0, 0, _Image ); 
        for i := 0 to Pred(_Image.Height) do begin 
            p := PByte( img.Picture.Bitmap.ScanLine[i] ); 
            for j := 0 to Pred(_Image.Width) do begin 
                Inc(p,2); 
                FStream.Write( p^, 1 ); 
                Dec(p); 
                FStream.Write( p^, 1 ); 
                Dec(p); 
                FStream.Write( p^, 1 ); 
                Inc(p,3); 
                end; 
            end; 
    finally 
        img.Free; 
    end; 
end; 
end.