{******************************************} { } { FastReport v4.0 } { PDF export filter } { } { Copyright (c) 1998-2009 } { by Alexander Fediachov, } { Fast Reports Inc. } { } {******************************************} unit frxExportPDF; interface {$I frx.inc} uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls, ExtCtrls, ComObj, Printers, frxClass, JPEG, ShellAPI, ComCtrls , frxRC4 {$IFDEF Delphi10} , WideStrings {$ENDIF} {$IFDEF Delphi12} , AnsiStrings {$ENDIF} {$IFDEF Delphi6}, Variants {$ENDIF}; (*$HPPEMIT '#pragma link "usp10.lib"'*) type SCRIPT_CACHE = Pointer; PScriptCache = ^SCRIPT_CACHE; SCRIPT_ANALYSIS = record fFlags: Word; s: Word end; PScriptAnalysis = ^SCRIPT_ANALYSIS; SCRIPT_ITEM = record iCharPos: Integer; a: SCRIPT_ANALYSIS; end; PScriptItem = ^SCRIPT_ITEM; GOFFSET = record du: Longint; dv: Longint; end; PGOffset = ^GOFFSET; function ScriptFreeCache(psc: PScriptCache): HRESULT; stdcall; external 'usp10.dll' name 'ScriptFreeCache'; function ScriptItemize(const pwcInChars: PWideChar; cInChars: Integer; cMaxItems: Integer; const psControl: PWord; const psState: PWord; pItems: PScriptItem; pcItems: PInteger): HRESULT; stdcall; external 'usp10.dll' name 'ScriptItemize'; function ScriptLayout(cRuns: Integer; const pbLevel: PByte; piVisualToLogical: PInteger; piLogicalToVisual: PInteger): HRESULT; stdcall; external 'usp10.dll' name 'ScriptLayout'; function ScriptShape(hdc: HDC; psc: PScriptCache; const pwcChars: PWideChar; cChars: Integer; cMaxGlyphs: Integer; psa: PScriptAnalysis; pwOutGlyphs: PWord; pwLogClust: PWord; psva: PWord; pcGlyphs: PInteger): HRESULT; stdcall; external 'usp10.dll' name 'ScriptShape'; function ScriptPlace(hdc: HDC; psc: PScriptCache; const pwGlyphs: PWord; cGlyphs: Integer; const psva: PWord; psa: PScriptAnalysis; piAdvance: PInteger; const pGoffset: PGOffset; pABC: PABC): HRESULT; stdcall; external 'usp10.dll' name 'ScriptPlace'; type TfrxPDFEncBit = (ePrint, eModify, eCopy, eAnnot); TfrxPDFEncBits = set of TfrxPDFEncBit; TfrxPDFExportDialog = class(TForm) PageControl1: TPageControl; ExportPage: TTabSheet; InfoPage: TTabSheet; SecurityPage: TTabSheet; ViewerPage: TTabSheet; OkB: TButton; CancelB: TButton; SaveDialog1: TSaveDialog; OpenCB: TCheckBox; GroupQuality: TGroupBox; CompressedCB: TCheckBox; EmbeddedCB: TCheckBox; PrintOptCB: TCheckBox; OutlineCB: TCheckBox; BackgrCB: TCheckBox; GroupPageRange: TGroupBox; DescrL: TLabel; AllRB: TRadioButton; CurPageRB: TRadioButton; PageNumbersRB: TRadioButton; PageNumbersE: TEdit; SecGB: TGroupBox; OwnPassL: TLabel; UserPassL: TLabel; OwnPassE: TEdit; UserPassE: TEdit; PermGB: TGroupBox; PrintCB: TCheckBox; ModCB: TCheckBox; CopyCB: TCheckBox; AnnotCB: TCheckBox; DocInfoGB: TGroupBox; TitleL: TLabel; TitleE: TEdit; AuthorE: TEdit; AuthorL: TLabel; SubjectL: TLabel; SubjectE: TEdit; KeywordsL: TLabel; KeywordsE: TEdit; CreatorE: TEdit; CreatorL: TLabel; ProducerL: TLabel; ProducerE: TEdit; ViewerGB: TGroupBox; HideToolbarCB: TCheckBox; HideMenubarCB: TCheckBox; HideWindowUICB: TCheckBox; FitWindowCB: TCheckBox; CenterWindowCB: TCheckBox; PrintScalingCB: TCheckBox; procedure FormCreate(Sender: TObject); procedure PageNumbersEChange(Sender: TObject); procedure PageNumbersEKeyPress(Sender: TObject; var Key: Char); procedure FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); end; type TfrxPDFRun = class public analysis: SCRIPT_ANALYSIS; text: WideString; constructor Create(t: WideString; a: SCRIPT_ANALYSIS); end; TfrxPDFFont = class private tempBitmap: TBitmap; FUSCache: PScriptCache; function GetGlyphs(hdc: HDC; run: TfrxPDFRun; glyphs: PWord; widths: PInteger; maxGlyphs: integer; rtl: boolean): Integer; function Itemize(s: WideString; rtl: boolean; maxItems: Integer): TList; function Layout(runs: TList; rtl: boolean): TList; function GetGlyphIndices(hdc: HDC; text: WideString; glyphs: PWord; widths: PInteger; rtl: boolean): integer; public Index: Integer; Widths: TList; UsedAlphabet: TList; UsedAlphabetUnicode: TList; TextMetric: ^OUTLINETEXTMETRICA; Name: AnsiString; SourceFont: TFont; Reference: Longint; Saved: Boolean; FontData: PAnsiChar; FontDataSize: Longint; PDFdpi_divider: double; FDpiFX: double; constructor Create(Font: TFont); destructor Destroy; override; procedure Cleanup; procedure FillOutlineTextMetrix; procedure GetFontFile; function RemapString(str: WideString; rtl: Boolean): WideString; function GetFontName: AnsiString; end; TfrxPDFExport = class(TfrxCustomExportFilter) private FCompressed: Boolean; FEmbedded: Boolean; FOpenAfterExport: Boolean; FPrintOpt: Boolean; FOutline: Boolean; FSubject: WideString; FAuthor: WideString; FBackground: Boolean; FCreator: WideString; FTags: Boolean; FProtection: Boolean; FUserPassword: AnsiString; FOwnerPassword: AnsiString; FProtectionFlags: TfrxPDFEncBits; FKeywords: WideString; FTitle: WideString; FProducer: WideString; FPrintScaling: Boolean; FFitWindow: Boolean; FHideMenubar: Boolean; FCenterWindow: Boolean; FHideWindowUI: Boolean; FHideToolbar: Boolean; pdf: TStream; FRootNumber: longint; FPagesNumber: longint; FInfoNumber: longint; FStartXRef: longint; FFonts: TList; FPageFonts: TList; FXRef: TStringList; FPagesRef: TStringList; FWidth: Extended; FHeight: Extended; FMarginLeft: Extended; FMarginWoBottom: Extended; FMarginTop: Extended; FEncKey: AnsiString; FOPass: AnsiString; FUPass: AnsiString; FEncBits: Cardinal; FFileID: AnsiString; FDivider: Extended; FLastColor: TColor; FLastColorResult: String; OutStream: TMemoryStream; function PrepXrefPos(pos: Longint): String; procedure Write(Stream: TStream; const S: AnsiString);{$IFDEF Delphi12} overload; procedure Write(Stream: TStream; const S: String); overload; {$ENDIF} procedure WriteLn(Stream: TStream; const S: AnsiString);{$IFDEF Delphi12} overload; procedure WriteLn(Stream: TStream; const S: String); overload; {$ENDIF} function GetID: AnsiString; function CryptStr(Source: AnsiString; Key: AnsiString; Enc: Boolean; id: Integer): AnsiString; function CryptStream(Source: TStream; Target: TStream; Key: AnsiString; id: Integer): AnsiString; function PrepareString(const Text: WideString; Key: AnsiString; Enc: Boolean; id: Integer): AnsiString; function EscapeSpecialChar(TextStr: AnsiString): AnsiString; function StrToUTF16(const Value: WideString): AnsiString; function PMD52Str(p: Pointer): AnsiString; function PadPassword(Password: AnsiString): AnsiString; procedure PrepareKeys; procedure SetProtectionFlags(const Value: TfrxPDFEncBits); procedure Clear; procedure WriteFont(pdfFont: TfrxPDFFont); procedure AddObject(const Obj: TfrxView); function StrToHex(const Value: WideString): AnsiString; function ObjNumber(FNumber: longint): String; function ObjNumberRef(FNumber: longint): String; function UpdateXRef: longint; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; class function GetDescription: String; override; function ShowModal: TModalResult; override; function Start: Boolean; override; procedure ExportObject(Obj: TfrxComponent); override; procedure Finish; override; procedure StartPage(Page: TfrxReportPage; Index: Integer); override; procedure FinishPage(Page: TfrxReportPage; Index: Integer); override; published property Compressed: Boolean read FCompressed write FCompressed default True; property EmbeddedFonts: Boolean read FEmbedded write FEmbedded default False; property OpenAfterExport: Boolean read FOpenAfterExport write FOpenAfterExport default False; property PrintOptimized: Boolean read FPrintOpt write FPrintOpt; property Outline: Boolean read FOutline write FOutline; property Background: Boolean read FBackground write FBackground; property HTMLTags: Boolean read FTags write FTags; property OverwritePrompt; property Title: WideString read FTitle write FTitle; property Author: WideString read FAuthor write FAuthor; property Subject: WideString read FSubject write FSubject; property Keywords: WideString read FKeywords write FKeywords; property Creator: WideString read FCreator write FCreator; property Producer: WideString read FProducer write FProducer; property UserPassword: AnsiString read FUserPassword write FUserPassword; property OwnerPassword: AnsiString read FOwnerPassword write FOwnerPassword; property ProtectionFlags: TfrxPDFEncBits read FProtectionFlags write SetProtectionFlags; property HideToolbar: Boolean read FHideToolbar write FHideToolbar; property HideMenubar: Boolean read FHideMenubar write FHideMenubar; property HideWindowUI: Boolean read FHideWindowUI write FHideWindowUI; property FitWindow: Boolean read FFitWindow write FFitWindow; property CenterWindow: Boolean read FCenterWindow write FCenterWindow; property PrintScaling: Boolean read FPrintScaling write FPrintScaling; end; implementation uses frxUtils, frxUnicodeUtils, frxFileUtils, frxRes, frxrcExports, frxGraphicUtils, frxGzip, frxMD5, ActiveX, SyncObjs, math; const PDF_VER = '1.5'; PDF_DIVIDER = 0.75; PDF_MARG_DIVIDER = 0.05; PDF_PRINTOPT = 3; PDF_PK: array [ 1..32 ] of Byte = ( $28, $BF, $4E, $5E, $4E, $75, $8A, $41, $64, $00, $4E, $56, $FF, $FA, $01, $08, $2E, $2E, $00, $B6, $D0, $68, $3E, $80, $2F, $0C, $A9, $FE, $64, $53, $69, $7A ); var pdfCS: TCriticalSection; {$R *.dfm} { TfrxPDFExport } constructor TfrxPDFExport.Create(AOwner: TComponent); begin inherited Create(AOwner); FCompressed := True; FPrintOpt := False; FAuthor := 'FastReport'; FSubject := 'FastReport PDF export'; FBackground := False; FCreator := 'FastReport'; FTags := True; FProtection := False; FUserPassword := ''; FOwnerPassword := ''; FProducer := ''; FKeywords := ''; FProtectionFlags := [ePrint, eModify, eCopy, eAnnot]; FilterDesc := frxGet(8707); DefaultExt := frxGet(8708); FCreator := Application.Name; FPrintScaling := False; FFitWindow := False; FHideMenubar := False; FCenterWindow := False; FHideWindowUI := False; FHideToolbar := False; FRootNumber := 0; FPagesNumber := 0; FInfoNumber := 0; FStartXRef := 0; FFonts := TList.Create; FPageFonts := TList.Create; FXRef := TStringList.Create; FPagesRef := TStringList.Create; FMarginLeft := 0; FMarginWoBottom := 0; FEncKey := ''; FOPass := ''; FUPass := ''; FEncBits := 0; FDivider := frxDrawText.DefPPI / frxDrawText.ScrPPI; FLastColor := clBlack; FLastColorResult := '0 0 0'; end; destructor TfrxPDFExport.Destroy; begin Clear; FFonts.Free; FPageFonts.Free; FXRef.Free; FPagesRef.Free; inherited; end; class function TfrxPDFExport.GetDescription: String; begin Result := frxResources.Get('PDFexport'); end; function TfrxPDFExport.ShowModal: TModalResult; var s: String; begin if FTitle = '' then FTitle := Report.ReportOptions.Name; if not Assigned(Stream) then begin if Assigned(Report) then FOutline := Report.PreviewOptions.OutlineVisible else FOutline := True; with TfrxPDFExportDialog.Create(nil) do begin OpenCB.Visible := not SlaveExport; if OverwritePrompt then SaveDialog1.Options := SaveDialog1.Options + [ofOverwritePrompt]; if SlaveExport then FOpenAfterExport := False; if (FileName = '') and (not SlaveExport) then begin s := ChangeFileExt(ExtractFileName(frxUnixPath2WinPath(Report.FileName)), SaveDialog1.DefaultExt); SaveDialog1.FileName := s; end else SaveDialog1.FileName := FileName; OpenCB.Checked := FOpenAfterExport; CompressedCB.Checked := FCompressed; EmbeddedCB.Checked := FEmbedded; PrintOptCB.Checked := FPrintOpt; OutlineCB.Checked := FOutline; OutlineCB.Enabled := FOutline; BackgrCB.Checked := FBackground; if PageNumbers <> '' then begin PageNumbersE.Text := PageNumbers; PageNumbersRB.Checked := True; end; OwnPassE.Text := String(FOwnerPassword); UserPassE.Text := String(FUserPassword); PrintCB.Checked := ePrint in FProtectionFlags; CopyCB.Checked := eCopy in FProtectionFlags; ModCB.Checked := eModify in FProtectionFlags; AnnotCB.Checked := eAnnot in FProtectionFlags; TitleE.Text := FTitle; AuthorE.Text := FAuthor; SubjectE.Text := FSubject; KeywordsE.Text := FKeywords; CreatorE.Text := FCreator; ProducerE.Text := FProducer; PrintScalingCB.Checked := FPrintScaling; FitWindowCB.Checked := FFitWindow; HideMenubarCB.Checked := FHideMenubar; CenterWindowCB.Checked := FCenterWindow; HideWindowUICB.Checked := FHideWindowUI; HideToolbarCB.Checked := FHideToolbar; Result := ShowModal; if Result = mrOk then begin FOwnerPassword := AnsiString(OwnPassE.Text); FUserPassword := AnsiString(UserPassE.Text); FProtectionFlags := []; if PrintCB.Checked then FProtectionFlags := FProtectionFlags + [ePrint]; if CopyCB.Checked then FProtectionFlags := FProtectionFlags + [eCopy]; if ModCB.Checked then FProtectionFlags := FProtectionFlags + [eModify]; if AnnotCB.Checked then FProtectionFlags := FProtectionFlags + [eAnnot]; PageNumbers := ''; CurPage := False; if CurPageRB.Checked then CurPage := True else if PageNumbersRB.Checked then PageNumbers := PageNumbersE.Text; FOpenAfterExport := OpenCB.Checked; FCompressed := CompressedCB.Checked; FEmbedded := EmbeddedCB.Checked; FPrintOpt := PrintOptCB.Checked; FOutline := OutlineCB.Checked; FBackground := BackgrCB.Checked; FTitle := TitleE.Text; FAuthor := AuthorE.Text; FSubject := SubjectE.Text; FKeywords := KeywordsE.Text; FCreator := CreatorE.Text; FProducer := ProducerE.Text; FPrintScaling := PrintScalingCB.Checked; FFitWindow := FitWindowCB.Checked; FHideMenubar := HideMenubarCB.Checked; FCenterWindow := CenterWindowCB.Checked; FHideWindowUI := HideWindowUICB.Checked; FHideToolbar := HideToolbarCB.Checked; if not SlaveExport then begin if DefaultPath <> '' then SaveDialog1.InitialDir := DefaultPath; if SaveDialog1.Execute then FileName := SaveDialog1.FileName else Result := mrCancel; end; end; Free; end; end else Result := mrOk; end; procedure TfrxPDFExport.Clear; var i: Integer; begin // destroy all of FFonts for i := 0 to FFonts.Count - 1 do TfrxPDFFont(FFonts[i]).Free; FFonts.Clear; // destroy all of FPageFonts FPageFonts.Clear; FXRef.Clear; FPagesRef.Clear; end; function TfrxPDFExport.GetID: AnsiString; var AGUID: TGUID; AGUIDString: widestring; begin CoCreateGUID(AGUID); SetLength(AGUIDString, 39); StringFromGUID2(AGUID, PWideChar(AGUIDString), 39); Result := AnsiString(PWideChar(AGUIDString)); MD5String(AnsiString(PWideChar(AGUIDString))); end; function TfrxPDFExport.Start: Boolean; begin if SlaveExport then begin if Report.FileName <> '' then FileName := ChangeFileExt(GetTemporaryFolder + ExtractFileName(Report.FileName), frxGet(8708)) else FileName := ChangeFileExt(GetTempFile, frxGet(8708)) end; if (FileName <> '') or Assigned(Stream) then begin if (ExtractFilePath(FileName) = '') and (DefaultPath <> '') then FileName := DefaultPath + '\' + FileName; FProtection := (FOwnerPassword <> '') or (FUserPassword <> ''); if Assigned(Stream) then pdf := Stream else pdf := TFileStream.Create(FileName, fmCreate); Result := True; // start here Clear; FFileID := MD5String(GetID); if FProtection then begin PrepareKeys; FEmbedded := true; end; WriteLn(pdf, '%PDF-' + PDF_VER); UpdateXRef; end else Result := False; end; procedure TfrxPDFExport.StartPage(Page: TfrxReportPage; Index: Integer); begin // start page FWidth := Page.Width * PDF_DIVIDER; FHeight := Page.Height * PDF_DIVIDER; FMarginLeft := Page.LeftMargin * PDF_MARG_DIVIDER; FMarginTop := Page.TopMargin * PDF_MARG_DIVIDER; OutStream := TMemoryStream.Create; end; procedure TfrxPDFExport.FinishPage(Page: TfrxReportPage; Index: Integer); var FContentsPos, FPagePos: Integer; s: String; i: Integer; TmpPageStream: TMemoryStream; TmpPageStream2: TMemoryStream; begin // finish page FContentsPos := UpdateXRef(); WriteLn(pdf, ObjNumber(FContentsPos)); Write(pdf, '<< '); TmpPageStream := TMemoryStream.Create; TmpPageStream2 := TMemoryStream.Create; try OutStream.Position := 0; TmpPageStream2.CopyFrom(OutStream, OutStream.Size); if FCompressed then begin frxDeflateStream(TmpPageStream2, TmpPageStream, gzFastest); s := '/Filter /FlateDecode /Length ' + IntToStr(TmpPageStream.Size) + ' /Length1 ' + IntToStr(TmpPageStream2.Size); end else s := '/Length ' + IntToStr(TmpPageStream2.Size); WriteLn(pdf, s + ' >>'); WriteLn(pdf, 'stream'); if FCompressed then begin if FProtection then CryptStream(TmpPageStream, pdf, FEncKey, FContentsPos) else pdf.CopyFrom(TmpPageStream, 0); WriteLn(pdf, ''); end else if FProtection then CryptStream(TmpPageStream2, pdf, FEncKey, FContentsPos) else pdf.CopyFrom(TmpPageStream2, 0); finally TmpPageStream2.Free; TmpPageStream.Free; end; WriteLn(pdf, 'endstream'); WriteLn(pdf, 'endobj'); OutStream.Free; if FPageFonts.Count > 0 then for i := 0 to FPageFonts.Count - 1 do if not TfrxPDFFont(FPageFonts[i]).Saved then begin TfrxPDFFont(FPageFonts[i]).Reference := UpdateXRef; TfrxPDFFont(FPageFonts[i]).Saved := true; end; FPagePos := UpdateXRef(); FPagesRef.Add(IntToStr(FPagePos)); WriteLn(pdf, ObjNumber(FPagePos)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Type /Page'); WriteLn(pdf, '/Parent 1 0 R'); WriteLn(pdf, '/MediaBox [0 0 ' + frFloat2Str(FWidth) + ' ' + frFloat2Str(FHeight) + ' ]'); WriteLn(pdf, '/Resources <<'); Write(pdf, '/Font << '); for i := 0 to FPageFonts.Count - 1 do {$IFDEF Delphi12} Write(pdf, TfrxPDFFont(FPageFonts[i]).Name + AnsiString(' ' + ObjNumberRef(TfrxPDFFont(FPageFonts[i]).Reference) + ' ')); {$ELSE} Write(pdf, TfrxPDFFont(FPageFonts[i]).Name + ' ' + ObjNumberRef(TfrxPDFFont(FPageFonts[i]).Reference) + ' '); {$ENDIF} WriteLn(pdf, '>>'); WriteLn(pdf, '/XObject <<'); WriteLn(pdf, '>>'); WriteLn(pdf, '/ProcSet [/PDF /Text /ImageC ]'); WriteLn(pdf, '>>'); WriteLn(pdf, '/Contents ' + ObjNumberRef(FContentsPos)); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); end; procedure TfrxPDFExport.ExportObject(Obj: TfrxComponent); begin if (Obj is TfrxView) and (ExportNotPrintable or TfrxView(Obj).Printable) then AddObject(Obj as TfrxView); end; procedure TfrxPDFExport.Finish; var i: Integer; s: String; FInfoNumber, FRootNumber: Longint; begin // finish file here for i := 0 to FFonts.Count - 1 do WriteFont(TfrxPDFFont(FFonts[i])); FPagesNumber := 1; FXRef[0] := PrepXrefPos(pdf.Position); WriteLn(pdf, ObjNumber(FPagesNumber)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Type /Pages'); Write(pdf, '/Kids ['); for i := 0 to FPagesRef.Count - 1 do Write(pdf, FPagesRef[i] + ' 0 R '); WriteLn(pdf, ']'); WriteLn(pdf, '/Count ' + IntTOStr(FPagesRef.Count)); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); FInfoNumber := UpdateXRef(); WriteLn(pdf, ObjNumber(FInfoNumber)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Title ' + PrepareString(FTitle, FEncKey, FProtection, FInfoNumber)); WriteLn(pdf, '/Author ' + PrepareString(FAuthor, FEncKey, FProtection, FInfoNumber)); WriteLn(pdf, '/Subject ' + PrepareString(FSubject, FEncKey, FProtection, FInfoNumber)); WriteLn(pdf, '/Keywords ' + PrepareString(FKeywords, FEncKey, FProtection, FInfoNumber)); WriteLn(pdf, '/Creator ' + PrepareString(FCreator, FEncKey, FProtection, FInfoNumber)); WriteLn(pdf, '/Producer ' + PrepareString(FProducer, FEncKey, FProtection, FInfoNumber)); s := 'D:' + FormatDateTime('yyyy', Now) + FormatDateTime('mm', Now) + FormatDateTime('dd', Now) + FormatDateTime('hh', Now) + FormatDateTime('nn', Now) + FormatDateTime('ss', Now); if FProtection then begin WriteLn(pdf, '/CreationDate ' + PrepareString(s, FEncKey, FProtection, FInfoNumber)); WriteLn(pdf, '/ModDate ' + PrepareString(s, FEncKey, FProtection, FInfoNumber)); end else begin WriteLn(pdf, '/CreationDate (' + s + ')'); WriteLn(pdf, '/ModDate (' + s + ')'); end; WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); FRootNumber := UpdateXRef(); WriteLn(pdf, ObjNumber(FRootNumber)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Type /Catalog'); WriteLn(pdf, '/Pages ' + ObjNumberRef(FPagesNumber)); WriteLn(pdf, '/PageMode /UseNone'); WriteLn(pdf, '/ViewerPreferences <<'); if FTitle <> '' then WriteLn(pdf, '/DisplayDocTitle true'); if FHideToolbar then WriteLn(pdf, '/HideToolbar true'); if FHideMenubar then WriteLn(pdf, '/HideMenubar true'); if FHideWindowUI then WriteLn(pdf, '/HideWindowUI true'); if FFitWindow then WriteLn(pdf, '/FitWindow true'); if FCenterWindow then WriteLn(pdf, '/CenterWindow true'); if not FPrintScaling then WriteLn(pdf, '/PrintScaling /None'); WriteLn(pdf, '>>'); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); FStartXRef := pdf.Position; WriteLn(pdf, 'xref'); WriteLn(pdf, '0 ' + IntToStr(FXRef.Count + 1)); WriteLn(pdf, '0000000000 65535 f'); for i := 0 to FXRef.Count - 1 do WriteLn(pdf, FXRef[i] + ' 00000 n'); WriteLn(pdf, 'trailer'); WriteLn(pdf, '<<'); WriteLn(pdf, '/Size ' + IntToStr(FXRef.Count + 1)); WriteLn(pdf, '/Root ' + ObjNumberRef(FRootNumber)); WriteLn(pdf, '/Info ' + ObjNumberRef(FInfoNumber)); WriteLn(pdf, '/ID [<' + FFileID + '><' + FFileID + '>]'); if FProtection then begin WriteLn(pdf, '/Encrypt <<'); WriteLn(pdf, '/Filter /Standard' ); WriteLn(pdf, '/V 2'); WriteLn(pdf, '/R 3'); WriteLn(pdf, '/Length 128'); WriteLn(pdf, '/P ' + IntToStr(Integer(FEncBits))); WriteLn(pdf, '/O (' + EscapeSpecialChar(FOPass) + ')'); WriteLn(pdf, '/U (' + EscapeSpecialChar(FUPass) + ')'); WriteLn(pdf, '>>'); end; WriteLn(pdf, '>>'); WriteLn(pdf, 'startxref'); WriteLn(pdf, IntToStr(FStartXRef)); WriteLn(pdf, '%%EOF'); Clear; if not Assigned(Stream) then pdf.Free; if FOpenAfterExport and (not Assigned(Stream)) then ShellExecute(GetDesktopWindow, 'open', PChar(FileName), nil, nil, SW_SHOW); end; procedure TfrxPDFExport.Write(Stream: TStream; const S: AnsiString); begin Stream.Write(S[1], Length(S)); end; procedure TfrxPDFExport.WriteLn(Stream: TStream; const S: AnsiString); begin Stream.Write(S[1], Length(S)); {$IFDEF Delphi12} Stream.Write(AnsiChar(#13)+AnsiChar(#10), 2); {$ELSE} Stream.Write(#13#10, 2); {$ENDIF} end; {$IFDEF Delphi12} procedure TfrxPDFExport.WriteLn(Stream: TStream; const S: String); begin WriteLn(Stream, AnsiString(s)); end; procedure TfrxPDFExport.Write(Stream: TStream; const S: String); begin Write(Stream, AnsiString(S)); end; {$ENDIF} function TfrxPDFExport.EscapeSpecialChar(TextStr: AnsiString): AnsiString; var I: Integer; begin Result := ''; for I := 1 to Length ( TextStr ) do case TextStr [ I ] of '(': Result := Result + '\('; ')': Result := Result + '\)'; '\': Result := Result + '\\'; #13: Result := result + '\r'; #10: Result := result + '\n'; else Result := Result + AnsiChar(chr ( Ord ( textstr [ i ] ) )); end; end; function TfrxPDFExport.CryptStr(Source: AnsiString; Key: AnsiString; Enc: Boolean; id: Integer): AnsiString; var k: array [ 1..21 ] of Byte; rc4: TfrxRC4; s, s1, ss: AnsiString; begin if Enc then begin rc4 := TfrxRC4.Create; try s := Key; FillChar(k, 21, 0); Move(s[1], k, 16); Move(id, k [17], 3); SetLength(s1, 21); MD5Buf(@k, 21, @s1[1]); ss := Source; SetLength(Result, Length(ss)); rc4.Start(@s1[1], 16); rc4.Crypt(@ss[1], @Result[1], Length(ss)); Result := EscapeSpecialChar(Result); finally rc4.Free; end; end else Result := EscapeSpecialChar(Source); end; function TfrxPDFExport.CryptStream(Source: TStream; Target: TStream; Key: AnsiString; id: Integer): AnsiString; var s: AnsiString; k: array [ 1..21 ] of Byte; rc4: TfrxRC4; m1, m2: TMemoryStream; begin FillChar(k, 21, 0); Move(Key[1], k, 16); Move(id, k[17], 3); SetLength(s, 16); MD5Buf(@k, 21, @s[1]); m1 := TMemoryStream.Create; m2 := TMemoryStream.Create; rc4 := TfrxRC4.Create; try m1.LoadFromStream(Source); m2.SetSize(m1.Size); rc4.Start(@s[1], 16); rc4.Crypt(m1.Memory, m2.Memory, m1.Size); m2.SaveToStream(Target); finally m1.Free; m2.Free; rc4.Free; end; end; function TfrxPDFExport.StrToUTF16(const Value: WideString): AnsiString; var i: integer; pwc: ^Word; begin result := 'FEFF'; for i := 1 to Length(Value) do begin pwc := @Value[i]; result := result + AnsiString(IntToHex(pwc^, 4)); end; end; function TfrxPDFExport.PrepareString(const Text: WideString; Key: AnsiString; Enc: Boolean; id: Integer): AnsiString; begin if Enc then begin Result := '(' + CryptStr(AnsiString(Text), Key, Enc, id) + ')' end else Result := '<' + StrToUTF16(Text) + '>' end; function TfrxPDFExport.PMD52Str(p: Pointer): AnsiString; begin SetLength(Result, 16); Move(p^, Result[1], 16); end; function TfrxPDFExport.PadPassword(Password: AnsiString): AnsiString; var i: Integer; begin i := Length(Password); Result := Copy(Password, 1, i); SetLength(Result, 32); if i < 32 then Move(PDF_PK, Result[i + 1], 32 - i); end; procedure TfrxPDFExport.PrepareKeys; var s, s1, p, p1, fid: AnsiString; i, j: Integer; rc4: TfrxRC4; md5: TfrxMD5; begin // OWNER KEY if FOwnerPassword = '' then FOwnerPassword := FUserPassword; p := PadPassword(FOwnerPassword); md5 := TfrxMD5.Create; try md5.Init; md5.Update(@p[1], 32); md5.Finalize; s := PMD52Str(md5.Digest); for i := 1 to 50 do begin md5.Init; md5.Update(@s[1], 16); md5.Finalize; s := PMD52Str(md5.Digest); end; finally md5.Free; end; rc4 := TfrxRC4.Create; try p := PadPassword(FUserPassword); SetLength(s1, 32); rc4.Start(@s[1], 16); rc4.Crypt(@p[1], @s1[1], 32); SetLength(p1, 16); for i := 1 to 19 do begin for j := 1 to 16 do p1[j] := AnsiChar(Byte(s[j]) xor i); rc4.Start(@p1[1], 16); rc4.Crypt(@s1[1], @s1[1], 32); end; FOPass := s1; finally rc4.Free; end; // ENCRYPTION KEY p := PadPassword(FUserPassword); md5 := TfrxMD5.Create; try md5.Init; md5.Update(@p[1], 32); md5.Update(@FOPass[1], 32); md5.Update(@FEncBits, 4); fid := ''; for i := 1 to 16 do fid := fid + AnsiChar(chr(Byte(StrToInt('$' + String(FFileID[i * 2 - 1] + FFileID[i * 2]))))); md5.Update(@fid[1], 16); md5.Finalize; s := PMD52Str(md5.Digest); for i := 1 to 50 do begin md5.Init; md5.Update(@s[1], 16); md5.Finalize; s := PMD52Str(md5.Digest); end; finally md5.Free; end; FEncKey := s; // USER KEY md5 := TfrxMD5.Create; try md5.Update(@PDF_PK, 32); md5.Update(@fid[1], 16); md5.Finalize; s := PMD52Str(md5.Digest); s1 := FEncKey; rc4 := TfrxRC4.Create; try rc4.Start(@s1[1], 16 ); rc4.Crypt(@s[1], @s[1], 16 ); SetLength(p1, 16); for i := 1 to 19 do begin for j := 1 to 16 do p1[j] := AnsiChar(Byte(s1[j]) xor i); rc4.Start(@p1[1], 16 ); rc4.Crypt(@s[1], @s[1], 16 ); end; FUPass := s; finally rc4.Free; end; SetLength(FUPass, 32); FillChar(FUPass[17], 16, 0); finally md5.Free; end; end; procedure TfrxPDFExport.SetProtectionFlags(const Value: TfrxPDFEncBits); begin FProtectionFlags := Value; FEncBits := $FFFFFFC0; FEncBits := FEncBits + (Cardinal(ePrint in Value) shl 2 + Cardinal(eModify in Value) shl 3 + Cardinal(eCopy in Value) shl 4 + Cardinal(eAnnot in Value) shl 5); end; procedure TfrxPDFExport.WriteFont(pdfFont: TfrxPDFFont); var fontFileId, descriptorId, toUnicodeId, cIDSystemInfoId, descendantFontId: Longint; fontName: String; i: Integer; memstream, fontstream, tounicode: TMemoryStream; begin fontFileId := 0; {$IFDEF Delphi12} fontName := String(pdfFont.GetFontName); {$ELSE} fontName := pdfFont.GetFontName; {$ENDIF} // embedded font if FEmbedded then begin fontFileId := UpdateXRef; WriteLn(pdf, ObjNumber(fontFileId)); pdfFont.GetFontFile; if FCompressed then begin memstream := TMemoryStream.Create; fontstream := TMemoryStream.Create; try fontstream.Write(pdfFont.FontData^, pdfFont.FontDataSize); frxDeflateStream(fontstream, memstream, gzFastest); WriteLn(pdf, '<< /Length ' + IntToStr(memstream.Size) + ' /Filter /FlateDecode /Length1 ' + IntToStr(fontstream.Size) + ' >>'); WriteLn(pdf, 'stream'); if FProtection then CryptStream(memstream, pdf, FEncKey, fontFileId) else pdf.CopyFrom(memstream, 0); finally memstream.Free; fontstream.Free; end; end else begin WriteLn(pdf, '<< /Length ' + IntToStr(pdfFont.FontDataSize) + ' /Length1 ' + IntToStr(pdfFont.FontDataSize) + ' >>'); WriteLn(pdf, 'stream'); if FProtection then begin fontstream := TMemoryStream.Create; try fontstream.Write(pdfFont.FontData^, pdfFont.FontDataSize); CryptStream(fontstream, pdf, FEncKey, fontFileId) finally fontstream.Free; end; end else pdf.Write(pdfFont.FontData^, pdfFont.FontDataSize); end; WriteLn(pdf, ''); WriteLn(pdf, 'endstream'); WriteLn(pdf, 'endobj'); end; // descriptor descriptorId := UpdateXRef; WriteLn(pdf, ObjNumber(descriptorId)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Type /FontDescriptor'); WriteLn(pdf, '/FontName /' + fontName); WriteLn(pdf, '/FontFamily /' + fontName); WriteLn(pdf, '/Flags 32'); WriteLn(pdf, '/FontBBox [' + IntToStr(pdfFont.TextMetric^.otmrcFontBox.left) + ' ' + IntToStr(pdfFont.TextMetric^.otmrcFontBox.bottom) + ' ' + IntToStr(pdfFont.TextMetric.otmrcFontBox.right) + ' ' + IntToStr(pdfFont.TextMetric.otmrcFontBox.top) + ' ]'); WriteLn(pdf, '/ItalicAngle ' + IntToStr(pdfFont.TextMetric^.otmItalicAngle)); WriteLn(pdf, '/Ascent ' + IntToStr(pdfFont.TextMetric^.otmAscent)); WriteLn(pdf, '/Descent ' + IntToStr(pdfFont.TextMetric^.otmDescent)); WriteLn(pdf, '/Leading ' + IntToStr(pdfFont.TextMetric^.otmTextMetrics.tmInternalLeading)); WriteLn(pdf, '/CapHeight ' + IntToStr(pdfFont.TextMetric^.otmTextMetrics.tmHeight)); WriteLn(pdf, '/StemV ' + IntToStr(50 + Round(sqr(pdfFont.TextMetric^.otmTextMetrics.tmWeight / 65)))); WriteLn(pdf, '/AvgWidth ' + IntToStr(pdfFont.TextMetric^.otmTextMetrics.tmAveCharWidth)); WriteLn(pdf, '/MxWidth ' + IntToStr(pdfFont.TextMetric^.otmTextMetrics.tmMaxCharWidth)); WriteLn(pdf, '/MissingWidth ' + IntToStr(pdfFont.TextMetric^.otmTextMetrics.tmAveCharWidth)); if FEmbedded then WriteLn(pdf, '/FontFile2 ' + ObjNumberRef(fontFileId)); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); // ToUnicode toUnicodeId := UpdateXRef(); WriteLn(pdf, ObjNumber(toUnicodeId)); tounicode := TMemoryStream.Create; try WriteLn(tounicode, '/CIDInit /ProcSet findresource begin'); WriteLn(tounicode, '12 dict begin'); WriteLn(tounicode, 'begincmap'); WriteLn(tounicode, '/CIDSystemInfo'); WriteLn(tounicode, '<< /Registry (Adobe)'); WriteLn(tounicode, '/Ordering (UCS)'); WriteLn(tounicode, '/Ordering (Identity)'); WriteLn(tounicode, '/Supplement 0'); WriteLn(tounicode, '>> def'); Write(tounicode, '/CMapName /'); {$IFDEF Delphi12} Write(tounicode, StringReplace(pdfFont.GetFontName, AnsiString(','), AnsiString('+'), [rfReplaceAll])); {$ELSE} Write(tounicode, StringReplace(pdfFont.GetFontName, ',', '+', [rfReplaceAll])); {$ENDIF} WriteLn(tounicode, ' def'); WriteLn(tounicode, '/CMapType 2 def'); WriteLn(tounicode, '1 begincodespacerange'); WriteLn(tounicode, '<0000> '); WriteLn(tounicode, 'endcodespacerange'); Write(tounicode, IntToStr(pdfFont.UsedAlphabet.Count)); WriteLn(tounicode, ' beginbfchar'); for i := 0 to pdfFont.UsedAlphabet.Count - 1 do begin Write(tounicode, '<'); Write(tounicode, IntToHex(Word(pdfFont.UsedAlphabet[i]), 4)); Write(tounicode, '> <'); Write(tounicode, IntToHex(Word(pdfFont.UsedAlphabetUnicode[i]), 4)); WriteLn(tounicode, '>'); end; WriteLn(tounicode, 'endbfchar'); WriteLn(tounicode, 'endcmap'); WriteLn(tounicode, 'CMapName currentdict /CMap defineresource pop'); WriteLn(tounicode, 'end'); WriteLn(tounicode, 'end'); tounicode.Position := 0; if FCompressed then begin memstream := TMemoryStream.Create; try frxDeflateStream(tounicode, memstream, gzFastest); WriteLn(pdf, '<< /Length ' + IntToStr(memstream.Size) + ' /Filter /FlateDecode /Length1 ' + IntToStr(tounicode.Size) + ' >>'); WriteLn(pdf, 'stream'); if FProtection then CryptStream(memstream, pdf, FEncKey, toUnicodeId) else pdf.CopyFrom(memstream, 0); finally memstream.Free; end; end else begin WriteLn(pdf, '<< /Length ' + IntToStr(tounicode.Size) + ' /Length1 ' + IntToStr(tounicode.Size) + ' >>'); WriteLn(pdf, 'stream'); if FProtection then CryptStream(tounicode, pdf, FEncKey, toUnicodeId) else pdf.CopyFrom(tounicode, 0); end; WriteLn(pdf, 'endstream'); WriteLn(pdf, 'endobj'); finally tounicode.Free; end; //CIDSystemInfo cIDSystemInfoId := UpdateXRef; WriteLn(pdf, ObjNumber(cIDSystemInfoId)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Registry (Adobe) /Ordering (Identity) /Supplement 0'); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); //DescendantFonts descendantFontId := UpdateXRef; WriteLn(pdf, ObjNumber(descendantFontId)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Type /Font'); WriteLn(pdf, '/Subtype /CIDFontType2'); WriteLn(pdf, '/BaseFont /' + fontName); WriteLn(pdf, '/CIDSystemInfo ' + ObjNumberRef(cIDSystemInfoId)); WriteLn(pdf, '/FontDescriptor ' + ObjNumberRef(descriptorId)); Write(pdf, '/W [ '); for i := 0 to pdfFont.UsedAlphabet.Count - 1 do Write(pdf, IntToStr(Word(pdfFont.UsedAlphabet[i])) + ' [' + IntToStr(Integer(pdfFont.Widths [i])) + '] '); WriteLn(pdf, ']'); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); // main FXRef[pdfFont.Reference - 1] := PrepXrefPos(pdf.Position); WriteLn(pdf, ObjNumber(pdfFont.Reference)); WriteLn(pdf, '<<'); WriteLn(pdf, '/Type /Font'); WriteLn(pdf, '/Subtype /Type0'); WriteLn(pdf, '/BaseFont /' + fontName); WriteLn(pdf, '/Encoding /Identity-H'); WriteLn(pdf, '/DescendantFonts [' + ObjNumberRef(descendantFontId) + ']'); WriteLn(pdf, '/ToUnicode ' + ObjNumberRef(toUnicodeId)); WriteLn(pdf, '>>'); WriteLn(pdf, 'endobj'); end; function TfrxPDFExport.StrToHex(const Value: WideString): AnsiString; var i: integer; begin result := ''; for i := 1 to Length(Value) do result := result + AnsiString(IntToHex(Word(Value[i]), 4)); end; function TfrxPDFExport.ObjNumber(FNumber: longint): String; begin result := IntToStr(FNumber) + ' 0 obj'; end; function TfrxPDFExport.ObjNumberRef(FNumber: longint): String; begin result := IntToStr(FNumber) + ' 0 R'; end; function TfrxPDFExport.PrepXrefPos(pos: Longint): String; begin result := StringOfChar('0', 10 - Length(IntToStr(pos))) + IntToStr(pos) end; function TfrxPDFExport.UpdateXRef: longint; begin FXRef.Add(PrepXrefPos(pdf.Position)); result := FXRef.Count; end; procedure TfrxPDFExport.AddObject(const Obj: TfrxView); var FontIndex: Integer; x, y, dx, dy, fdx, fdy, PGap, FCharSpacing, ow, oh: Extended; i, iz: Integer; Jpg: TJPEGImage; s: AnsiString; su: WideString; Lines: TWideStrings; TempBitmap: TBitmap; OldFrameWidth: Extended; TempColor: TColor; Left, Right, Top, Bottom, Width, Height, BWidth, BHeight: String; FUnderlineSize: Double; FRealBounds: TfrxRect; FLineHeight: Extended; FLineWidth: Extended; FHeightWoMargin: Extended; pdfFont: TfrxPDFFont; textObj: TfrxCustomMemoView; bx, by, bx1, by1, wx1, wx2, wy1, wy2, gx1, gy1: Integer; FTextRect: TRect; function GetLeft(const Left: Extended): Extended; begin Result := FMarginLeft + Left * PDF_DIVIDER end; function GetTop(const Top: Extended): Extended; begin Result := FHeightWoMargin - Top * PDF_DIVIDER end; function GetVTextPos(const Top: Extended; const Height: Extended; const Align: TfrxVAlign; const Line: Integer = 0; const Count: Integer = 1): Extended; var i: Integer; begin if Line <= Count then i := Line else i := 0; if Align = vaBottom then Result := Top + Height - FLineHeight * (Count - i - 1) else if Align = vaCenter then Result := Top + (Height - (FLineHeight * Count)) / 2 + FLineHeight * (i + 1) else Result := Top + FLineHeight * (i + 1); end; function GetHTextPos(const Left: Extended; const Width: Extended; const Text: WideString; const Align: TfrxHAlign): Extended; var txt: TWideStrings; begin if (Align = haLeft) or (Align = haBlock) then Result := Left else begin {$IFDEF Delphi10} txt := TfrxWideStrings.Create; {$ELSE} txt := TWideStrings.Create; {$ENDIF} try txt.Add(Text); frxDrawText.SetText(txt); FLineWidth := frxDrawText.CalcWidth; finally txt.Free; end; if Align = haCenter then Result := Left + (Width - FLineWidth) / 2 else Result := Left + Width - FLineWidth; end; end; function GetPDFColor(const Color: TColor): String; var TheRgbValue : TColorRef; begin if Color = clBlack then Result := '0 0 0' else if Color = clWhite then Result := '1 1 1' else if Color = FLastColor then Result := FLastColorResult else begin TheRgbValue := ColorToRGB(Color); Result:= frFloat2Str(Byte(TheRGBValue) / 255) + ' ' + frFloat2Str(Byte(TheRGBValue shr 8) / 255) + ' ' + frFloat2Str(Byte(TheRGBValue shr 16) / 255); FLastColor := Color; FLastColorResult := Result; end; end; procedure MakeUpFrames; begin if (Obj.Frame.Typ <> []) and (Obj.Frame.Color <> clNone) then begin Write(OutStream, GetPDFColor(Obj.Frame.Color) + ' RG'#13#10 + frFloat2Str(Obj.Frame.Width * PDF_DIVIDER) + ' w'#13#10); if Obj.Frame.Typ = [ftTop, ftRight, ftBottom, ftLeft] then Write(OutStream, Left + ' ' + Top + ' m'#13#10 + Right + ' ' + Top + ' l'#13#10 + Right + ' ' + Bottom + ' l'#13#10 + Left + ' ' + Bottom + ' l'#13#10 + Left + ' ' + Top + ' l'#13#10's'#13#10) else begin if ftTop in Obj.Frame.Typ then Write(OutStream, Left + ' ' + Top + ' m'#13#10 + Right + ' ' + Top + ' l'#13#10'S'#13#10); if ftRight in Obj.Frame.Typ then Write(OutStream, Right + ' ' + Top + ' m'#13#10 + Right + ' ' + Bottom + ' l'#13#10'S'#13#10); if ftBottom in Obj.Frame.Typ then Write(OutStream, Left + ' ' + Bottom + ' m'#13#10 + Right + ' ' + Bottom + ' l'#13#10'S'#13#10); if ftLeft in Obj.Frame.Typ then Write(OutStream, Left + ' ' + Top + ' m'#13#10 + Left + ' ' + Bottom + ' l'#13#10'S'#13#10); end; end; end; function HTMLTags(const View: TfrxCustomMemoView): Boolean; begin if View.AllowHTMLTags then Result := FTags and (Pos('<' ,View.Memo.Text) > 0) else Result := False; end; function CheckOutPDFChars(const Str: WideString): WideString; var i: Integer; begin Result := ''; for i := 1 to Length(Str) do if Str[i] = '\' then Result := Result + '\\' else if Str[i] = '(' then Result := Result + '\(' else if Str[i] = ')' then Result := Result + '\)' else Result := Result + Str[i]; end; procedure DrawArrow(Obj: TfrxCustomLineView; x1, y1, x2, y2: Extended); var k1, a, b, c, D: Double; xp, yp, x3, y3, x4, y4, ld, wd: Extended; begin wd := Obj.ArrowWidth * PDF_DIVIDER; ld := Obj.ArrowLength * PDF_DIVIDER; if abs(x2 - x1) > 0 then begin k1 := (y2 - y1) / (x2 - x1); a := Sqr(k1) + 1; b := 2 * (k1 * ((x2 * y1 - x1 * y2) / (x2 - x1) - y2) - x2); c := Sqr(x2) + Sqr(y2) - Sqr(ld) + Sqr((x2 * y1 - x1 * y2) / (x2 - x1)) - 2 * y2 * (x2 * y1 - x1 * y2) / (x2 - x1); D := Sqr(b) - 4 * a * c; xp := (-b + Sqrt(D)) / (2 * a); if (xp > x1) and (xp > x2) or (xp < x1) and (xp < x2) then xp := (-b - Sqrt(D)) / (2 * a); yp := xp * k1 + (x2 * y1 - x1 * y2) / (x2 - x1); if y2 <> y1 then begin x3 := xp + wd * sin(ArcTan(k1)); y3 := yp - wd * cos(ArcTan(k1)); x4 := xp - wd * sin(ArcTan(k1)); y4 := yp + wd * cos(ArcTan(k1)); end else begin x3 := xp; y3 := yp - wd; x4 := xp; y4 := yp + wd; end; end else begin xp := x2; yp := y2 - ld; if (yp > y1) and (yp > y2) or (yp < y1) and (yp < y2) then yp := y2 + ld; x3 := xp - wd; y3 := yp; x4 := xp + wd; y4 := yp; end; WriteLn(OutStream, frFloat2Str(x3) + ' ' + frFloat2Str(y3) + ' m'#13#10 + frFloat2Str(x2) + ' ' + frFloat2Str(y2) + ' l'#13#10 + frFloat2Str(x4) + ' ' + frFloat2Str(y4) + ' l'); if Obj.ArrowSolid then WriteLn(OutStream, '1 j'#13#10 + GetPDFColor(Obj.Frame.Color) + ' rg'#13#10'b') else WriteLn(OutStream, 'S'); end; function GetGlobalFont(const Font: TFont): TfrxPDFFont; var i: Integer; Font2: TFont; begin for i := 0 to FFonts.Count - 1 do begin Font2 := TfrxPDFFont(FFonts[i]).SourceFont; if (Font.Name = Font2.Name) and (Font.Style = Font2.Style) then break; end; if i < FFonts.Count then result := TfrxPDFFont(FFonts[i]) else begin result := TfrxPDFFont.Create(Font); result.FillOutlineTextMetrix(); FFonts.Add(result); {$IFDEF Delphi12} result.Name := AnsiString('/F' + IntToStr(FFonts.Count - 1)); {$ELSE} result.Name := '/F' + IntToStr(FFonts.Count - 1); {$ENDIF} end; end; function GetObjFontNumber(const Font: TFont): integer; var i: Integer; Font2: TFont; begin for i := 0 to FPageFonts.Count - 1 do begin Font2 := TfrxPDFFont(FPageFonts[i]).SourceFont; if (Font.Name = Font2.Name) and (Font.Style = Font2.Style) then break; end; if i < FPageFonts.Count then result := i else begin FPageFonts.Add(GetGlobalFont(Font)); result := FPageFonts.Count - 1; end; end; begin FHeightWoMargin := FHeight - FMarginTop; Left := frFloat2Str(GetLeft(Obj.AbsLeft)); Top := frFloat2Str(GetTop(Obj.AbsTop)); Right := frFloat2Str(GetLeft(Obj.AbsLeft + Obj.Width)); Bottom := frFloat2Str(GetTop(Obj.AbsTop + Obj.Height)); Width := frFloat2Str(Obj.Width * PDF_DIVIDER); Height := frFloat2Str(Obj.Height * PDF_DIVIDER); OldFrameWidth := 0; // Text if (Obj is TfrxCustomMemoView) and (TfrxCustomMemoView(Obj).Rotation = 0) and (TfrxCustomMemoView(Obj).BrushStyle in [bsSolid, bsClear]) and (not HTMLTags(TfrxCustomMemoView(Obj))) then begin // save clip to stack Write(OutStream, 'q'#13#10); Write(OutStream, frFloat2Str(GetLeft(Obj.AbsLeft - Obj.Frame.Width)) + ' ' + frFloat2Str(GetTop(Obj.AbsTop + Obj.Height + Obj.Frame.Width)) + ' ' + frFloat2Str((Obj.Width + Obj.Frame.Width * 2) * PDF_DIVIDER) + ' ' + frFloat2Str((Obj.Height + Obj.Frame.Width * 2) * PDF_DIVIDER) + ' re'#13#10'W'#13#10'n'#13#10); ow := Obj.Width - Obj.Frame.ShadowWidth; oh := Obj.Height - Obj.Frame.ShadowWidth; // Shadow if Obj.Frame.DropShadow then begin Width := frFloat2Str(ow * PDF_DIVIDER); Height := frFloat2Str(oh * PDF_DIVIDER); Right := frFloat2Str(GetLeft(Obj.AbsLeft + ow)); Bottom := frFloat2Str(GetTop(Obj.AbsTop + oh)); s := AnsiString(GetPDFColor(Obj.Frame.ShadowColor)); Write(OutStream, s + ' rg'#13#10 + s + ' RG'#13#10 + AnsiString(frFloat2Str(GetLeft(Obj.AbsLeft + ow)) + ' ' + frFloat2Str(GetTop(Obj.AbsTop + oh + Obj.Frame.ShadowWidth)) + ' ' + frFloat2Str(Obj.Frame.ShadowWidth * PDF_DIVIDER) + ' ' + frFloat2Str(oh * PDF_DIVIDER) + ' re'#13#10'B'#13#10 + frFloat2Str(GetLeft(Obj.AbsLeft + Obj.Frame.ShadowWidth)) + ' ' + frFloat2Str(GetTop(Obj.AbsTop + oh + Obj.Frame.ShadowWidth)) + ' ' + frFloat2Str(ow * PDF_DIVIDER) + ' ' + frFloat2Str(Obj.Frame.ShadowWidth * PDF_DIVIDER) + ' re'#13#10'B'#13#10)); end; textObj := TfrxCustomMemoView(Obj); frxDrawText.Lock; pdfCS.Enter; try if textObj.Highlight.Active and Assigned(textObj.Highlight.Font) then begin textObj.Font.Assign(textObj.Highlight.Font); textObj.Color := textObj.Highlight.Color; end; frxDrawText.SetFont(textObj.Font); frxDrawText.SetOptions(true, textObj.AllowHTMLTags, textObj.RTLReading, textObj.WordBreak, textObj.Clipped, textObj.Wysiwyg, textObj.Rotation); frxDrawText.SetGaps(textObj.ParagraphGap, textObj.CharSpacing, textObj.LineSpacing); wx1 := Round((textObj.Frame.Width - 1) / 2); wx2 := Round(textObj.Frame.Width / 2); wy1 := Round((textObj.Frame.Width - 1) / 2); wy2 := Round(textObj.Frame.Width / 2); bx := Round(textObj.AbsLeft); by := Round(textObj.AbsTop); bx1 := Round(textObj.AbsLeft + textObj.Width); by1 := Round(textObj.AbsTop + textObj.Height); if ftLeft in textObj.Frame.Typ then Inc(bx, wx1); if ftRight in textObj.Frame.Typ then Dec(bx1, wx2); if ftTop in textObj.Frame.Typ then Inc(by, wy1); if ftBottom in textObj.Frame.Typ then Dec(by1, wy2); gx1 := Round(textObj.GapX); gy1 := Round(textObj.GapY); FTextRect := Rect(bx + gx1, by + gy1, bx1 - gx1 + 1, by1 - gy1 + 1); frxDrawText.SetDimensions(1, 1, 1, FTextRect, FTextRect); frxDrawText.SetText(textObj.Memo); FLineHeight := frxDrawText.LineHeight; if textObj.Color <> clNone then Write(OutStream, GetPDFColor(textObj.Color) + ' rg'#13#10 + Left + ' ' + Bottom + ' ' + Width + ' ' + Height + ' re'#13#10'f'#13#10); // Frames MakeUpFrames; if textObj.Underlines then begin iz := Trunc(textObj.Height / FLineHeight); for i:= 0 to iz - 1 do begin y := GetTop(textObj.AbsTop + textObj.GapY + 1 + FLineHeight * (i + 1)); Write(OutStream, GetPDFColor(textObj.Frame.Color) + ' RG'#13#10 + frFloat2Str(textObj.Frame.Width * PDF_DIVIDER) + ' w'#13#10 + Left + ' ' + frFloat2Str(y) + ' m'#13#10 + Right + ' ' + frFloat2Str(y) + ' l'#13#10'S'#13#10); end; end; {$IFDEF Delphi10} Lines := TfrxWideStrings.Create; {$ELSE} Lines := TWideStrings.Create; {$ENDIF} Lines.Text := frxDrawText.WrappedText; if Lines.Count > 0 then begin FontIndex := GetObjFontNumber(textObj.Font); pdfFont := TfrxPDFFont(FPageFonts[FontIndex]); {$IFDEF Delphi12} Write(OutStream, TfrxPDFFont(FFonts[FontIndex]).Name + AnsiString(' ' + IntToStr(textObj.Font.Size) + ' Tf'#13#10)); {$ELSE} Write(OutStream, TfrxPDFFont(FFonts[FontIndex]).Name + ' ' + IntToStr(textObj.Font.Size) + ' Tf'#13#10); {$ENDIF} if textObj.Font.Color <> clNone then TempColor := textObj.Font.Color else TempColor := clBlack; Write(OutStream, GetPDFColor(TempColor) + ' rg'#13#10); FCharSpacing := textObj.CharSpacing * PDF_DIVIDER; if FCharSpacing <> 0 then Write(OutStream, frFloat2Str(FCharSpacing) + ' Tc'#13#10); // output lines of memo FUnderlineSize := textObj.Font.Size * 0.12; frxDrawText.SetGaps(0, TfrxCustomMemoView(Obj).CharSpacing, TfrxCustomMemoView(Obj).LineSpacing); for i := 0 to Lines.Count - 1 do begin if i = 0 then PGap := textObj.ParagraphGap else PGap := 0; if Length(Lines[i]) > 0 then begin // Text output if textObj.HAlign <> haRight then FCharSpacing := 0; x := FCharSpacing + GetLeft(GetHTextPos(textObj.AbsLeft + textObj.GapX + textObj.Font.Size * 0.01 + textObj.GapX / 2 + PGap, ow - textObj.GapX * 2 - PGap, Lines[i], textObj.HAlign)); y := GetTop(GetVTextPos(textObj.AbsTop + textObj.GapY - textObj.Font.Size * 0.1, oh - textObj.GapY * 2, textObj.VAlign, i, Lines.Count)); Write(OutStream, 'BT'#13#10); Write(OutStream, frFloat2Str(x) + ' ' + frFloat2Str(y) + ' Td'#13#10); Write(OutStream, '<' + StrToHex(pdfFont.RemapString(Lines[i], textObj.RTLReading)) + '> Tj'#13#10'ET'#13#10); // set Underline if fsUnderline in (textObj.Font.Style) then Write(OutStream, GetPDFColor(textObj.Font.Color) + ' RG'#13#10 + frFloat2Str(textObj.Font.Size * 0.08) + ' w'#13#10 + frFloat2Str(x) + ' ' + frFloat2Str(y - FUnderlineSize) + ' m'#13#10 + frFloat2Str(x + FLineWidth * PDF_DIVIDER) + ' ' + frFloat2Str(y - FUnderlineSize) + ' l'#13#10'S'#13#10); end; end; end; finally frxDrawText.Unlock; pdfCS.Leave; end; // restore clip Write(OutStream, 'Q'#13#10); Lines.Free; end // Lines else if Obj is TfrxCustomLineView then begin Write(OutStream, GetPDFColor(Obj.Frame.Color) + ' RG'#13#10 + frFloat2Str(Obj.Frame.Width * PDF_DIVIDER) + ' w'#13#10 + Left + ' ' + Top + ' m'#13#10 + Right + ' ' + Bottom + ' l'#13#10'S'#13#10); if TfrxCustomLineView(Obj).ArrowStart then DrawArrow(TfrxCustomLineView(Obj), GetLeft(Obj.AbsLeft + Obj.Width), GetTop(Obj.AbsTop + Obj.Height), GetLeft(Obj.AbsLeft), GetTop(Obj.AbsTop)); if TfrxCustomLineView(Obj).ArrowEnd then DrawArrow(TfrxCustomLineView(Obj), GetLeft(Obj.AbsLeft), GetTop(Obj.AbsTop), GetLeft(Obj.AbsLeft + Obj.Width), GetTop(Obj.AbsTop + Obj.Height)); end // Rects else if (Obj is TfrxShapeView) and (TfrxShapeView(Obj).Shape = skRectangle) then begin Write(OutStream, GetPDFColor(Obj.Frame.Color) + ' RG'#13#10 + frFloat2Str(Obj.Frame.Width * PDF_DIVIDER) + ' w'#13#10 + GetPDFColor(Obj.Color) + ' rg'#13#10 + Left + ' ' + Bottom + ' '#13#10 + Width + ' ' + Height + ' re'#13#10); if Obj.Color <> clNone then Write(OutStream, 'B'#13#10) else Write(OutStream, 'S'#13#10); end // Shape line 1 else if (Obj is TfrxShapeView) and (TfrxShapeView(Obj).Shape = skDiagonal1) then Write(OutStream, GetPDFColor(Obj.Frame.Color) + ' RG'#13#10 + frFloat2Str(Obj.Frame.Width * PDF_DIVIDER) + ' w'#13#10 + Left + ' ' + Bottom + ' m'#13#10 + Right + ' ' + Top + ' l'#13#10'S'#13#10) // Shape line 2 else if (Obj is TfrxShapeView) and (TfrxShapeView(Obj).Shape = skDiagonal2) then Write(OutStream, GetPDFColor(Obj.Frame.Color) + ' RG'#13#10 + frFloat2Str(Obj.Frame.Width * PDF_DIVIDER) + ' w'#13#10 + Left + ' ' + Top + ' m'#13#10 + Right + ' ' + Bottom + ' l'#13#10'S'#13#10) else // Bitmaps if not ((Obj.Name = '_pagebackground') and (not Background)) and (Obj.Height > 0) and (Obj.Width > 0) then begin if Obj.Frame.Width > 0 then begin OldFrameWidth := Obj.Frame.Width; Obj.Frame.Width := 0; end; FRealBounds := Obj.GetRealBounds; dx := FRealBounds.Right - FRealBounds.Left; dy := FRealBounds.Bottom - FRealBounds.Top; if (dx = Obj.Width) or (Obj.AbsLeft = FRealBounds.Left) then fdx := 0 else if (Obj.AbsLeft + Obj.Width) = FRealBounds.Right then fdx := (dx - Obj.Width) else fdx := (dx - Obj.Width) / 2; if (dy = Obj.Height) or (Obj.AbsTop = FRealBounds.Top) then fdy := 0 else if (Obj.AbsTop + Obj.Height) = FRealBounds.Bottom then fdy := (dy - Obj.Height) else fdy := (dy - Obj.Height) / 2; TempBitmap := TBitmap.Create; TempBitmap.PixelFormat := pf24bit; if (PrintOptimized or (Obj is TfrxCustomMemoView)) and (Obj.BrushStyle in [bsSolid, bsClear]) then i := PDF_PRINTOPT else i := 1; iz := 0; if (Obj.ClassName = 'TfrxBarCodeView') and not PrintOptimized then begin i := 2; iz := i; end; TempBitmap.Width := Round(dx * i) + i; TempBitmap.Height := Round(dy * i) + i; Obj.Draw(TempBitmap.Canvas, i, i, -Round((Obj.AbsLeft - fdx) * i) + iz, -Round((Obj.AbsTop - fdy)* i)); if dx <> 0 then BWidth := frFloat2Str(dx * PDF_DIVIDER) else BWidth := '1'; if dy <> 0 then BHeight := frFloat2Str(dy * PDF_DIVIDER) else BHeight := '1'; Write(OutStream, 'q'#13#10 + BWidth + ' 0 0 ' + BHeight + ' ' + frFloat2Str(GetLeft(Obj.AbsLeft - fdx)) + ' ' + frFloat2Str(GetTop(Obj.AbsTop - fdy + dy)) + ' cm'#13#10'BI'#13#10 + '/W ' + IntToStr(TempBitmap.Width) + #13#10 + '/H ' + IntToStr(TempBitmap.Height) + #13#10'/CS /RGB'#13#10'/BPC 8'#13#10'/I true'#13#10'/F [/DCT]'#13#10'ID'#13#10); Jpg := TJPEGImage.Create; if (Obj.ClassName = 'TfrxBarCodeView') or (Obj is TfrxCustomLineView) or (Obj is TfrxShapeView) then begin Jpg.PixelFormat := jf8Bit; Jpg.CompressionQuality := 95; end else begin Jpg.PixelFormat := jf24Bit; Jpg.CompressionQuality := 90; end; Jpg.Assign(TempBitmap); Jpg.SaveToStream(OutStream); Jpg.Free; Write(OutStream, #13#10'EI'#13#10'Q'#13#10); TempBitmap.Free; if OldFrameWidth > 0 then Obj.Frame.Width := OldFrameWidth; MakeUpFrames; end; end; { TfrxPDFExportDialog } procedure TfrxPDFExportDialog.FormCreate(Sender: TObject); begin Caption := frxGet(8700); OkB.Caption := frxGet(1); CancelB.Caption := frxGet(2); GroupPageRange.Caption := frxGet(7); AllRB.Caption := frxGet(3); CurPageRB.Caption := frxGet(4); PageNumbersRB.Caption := frxGet(5); DescrL.Caption := frxGet(9); GroupQuality.Caption := frxGet(8); CompressedCB.Caption := frxGet(8701); EmbeddedCB.Caption := frxGet(8702); PrintOptCB.Caption := frxGet(8703); OutlineCB.Caption := frxGet(8704); BackgrCB.Caption := frxGet(8705); OpenCB.Caption := frxGet(8706); SaveDialog1.Filter := frxGet(8707); SaveDialog1.DefaultExt := frxGet(8708); ExportPage.Caption := frxGet(107); DocInfoGB.Caption := frxGet(8971); InfoPage.Caption := frxGet(8972); TitleL.Caption := frxGet(8973); AuthorL.Caption := frxGet(8974); SubjectL.Caption := frxGet(8975); KeywordsL.Caption := frxGet(8976); CreatorL.Caption := frxGet(8977); ProducerL.Caption := frxGet(8978); SecurityPage.Caption := frxGet(8962); SecGB.Caption := frxGet(8979); PermGB.Caption := frxGet(8980); OwnPassL.Caption := frxGet(8964); UserPassL.Caption := frxGet(8965); PrintCB.Caption := frxGet(8966); ModCB.Caption := frxGet(8967); CopyCB.Caption := frxGet(8968); AnnotCB.Caption := frxGet(8969); ViewerPage.Caption := frxGet(8981); ViewerGB.Caption := frxGet(8982); HideToolbarCB.Caption := frxGet(8983); HideMenubarCB.Caption := frxGet(8984); HideWindowUICB.Caption := frxGet(8985); FitWindowCB.Caption := frxGet(8986); CenterWindowCB.Caption := frxGet(8987); PrintScalingCB.Caption := frxGet(8988); if UseRightToLeftAlignment then FlipChildren(True); end; procedure TfrxPDFExportDialog.PageNumbersEChange(Sender: TObject); begin PageNumbersRB.Checked := True; end; procedure TfrxPDFExportDialog.PageNumbersEKeyPress(Sender: TObject; var Key: Char); begin case key of '0'..'9':; #8, '-', ',':; else key := #0; end; end; procedure TfrxPDFExportDialog.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if Key = VK_F1 then frxResources.Help(Self); end; { TfrxPDFFont } constructor TfrxPDFFont.Create(Font: TFont); var dpi: integer; begin SourceFont := TFont.Create; dpi := SourceFont.PixelsPerInch; SourceFont.Assign(Font); FDpiFX := 96 / dpi; PDFdpi_divider := 1 / (750 * FDpiFX); SourceFont.Size := Round(750 * FDpiFX); tempBitmap := TBitmap.Create; Widths := TList.Create; UsedAlphabet := TList.Create; UsedAlphabetUnicode := TList.Create; Saved := false; FontData := nil; FontDataSize := 0; TextMetric := nil; FUSCache := nil end; destructor TfrxPDFFont.Destroy; begin Cleanup; SourceFont.Free; Widths.Free; UsedAlphabet.Free; UsedAlphabetUnicode.Free; ScriptFreeCache(@FUSCache); inherited; end; procedure TfrxPDFFont.Cleanup; begin tempBitmap.Free; Widths.Clear; UsedAlphabet.Clear; UsedAlphabetUnicode.Clear; if FontDataSize > 0 then begin FreeMemory(FontData); FontDataSize := 0; FontData := nil; end; if TextMetric <> nil then begin FreeMemory(TextMetric); TextMetric := nil; end; end; function TfrxPDFFont.GetGlyphIndices(hdc: HDC; text: WideString; glyphs: PWord; widths: PInteger; rtl: boolean): integer; var maxGlyphs: Integer; maxItems: Integer; runs: TList; i, j, len: Integer; tempGlyphs, g1, g2: PWord; tempWidths, w1, w2: PInteger; run: TfrxPDFRun; begin if text = '' then result := 0 else begin maxGlyphs := Length(text) * 3; maxItems := Length(text) * 2; runs := Itemize(text, rtl, maxItems); runs := Layout(runs, rtl); result := 0; g2 := glyphs; w2 := widths; tempGlyphs := GetMemory(SizeOf(Word) * maxGlyphs); tempWidths := GetMemory(SizeOf(Integer) * maxGlyphs); try for i := 0 to runs.Count - 1 do begin run := TfrxPDFRun(runs[i]); len := GetGlyphs(hdc, run, tempGlyphs, tempWidths, maxGlyphs, rtl); g1 := tempGlyphs; w1 := tempWidths; for j := 1 to len do begin g2^ := g1^; w2^ := w1^; Inc(g1); Inc(g2); Inc(w1); Inc(w2); end; Inc(result, len); run.Free; end; finally FreeMemory(tempGlyphs); FreeMemory(tempWidths); end; runs.Free; end; end; function TfrxPDFFont.GetGlyphs(hdc: HDC; run: TfrxPDFRun; glyphs: PWord; widths: PInteger; maxGlyphs: integer; rtl: boolean): Integer; var psa: SCRIPT_ANALYSIS; pwLogClust: PWord; pcGlyphs: Integer; psva: PWord; pGoffset_: PGOffset; pABC_: PABC; begin psa := run.analysis; pcGlyphs := 0; pwLogClust := GetMemory(SizeOf(Word) * maxGlyphs); psva := GetMemory(SizeOf(Word) * maxGlyphs); pGoffset_ := GetMemory(SizeOf(GOffset) * maxGlyphs); pABC_ := GetMemory(SizeOf(ABC) * maxGlyphs); psa := run.analysis; try ScriptShape(hdc, @FUSCache, PWideChar(run.text), Length(run.text), maxGlyphs, @psa, glyphs, pwLogClust, psva, @pcGlyphs); ScriptPlace(hdc, @FUSCache, glyphs, pcGlyphs, psva, @psa, widths, pGoffset_, pABC_); finally FreeMemory(pwLogClust); FreeMemory(psva); FreeMemory(pGoffset_); FreeMemory(pABC_); end; Result := pcGlyphs; end; function TfrxPDFFont.Itemize(s: WideString; rtl: boolean; maxItems: Integer): TList; var pItems, pItems_: PScriptItem; pcItems: Integer; control: Word; state: Word; i: Integer; text: WideString; p1, p2: Integer; run: TfrxPDFRun; a: SCRIPT_ANALYSIS; begin pItems := GetMemory(SizeOf(SCRIPT_ITEM) * maxItems); try pcItems := 0; if rtl then state := 1 else state := 0; control := 0; ScriptItemize(PWideChar(s), Length(s), maxItems, @control, @state, pItems, @pcItems); result := TList.Create; pItems_ := pItems; for i := 0 to pcItems - 1 do begin p1 := pItems_^.iCharPos; a := pItems_^.a; Inc(pItems_); p2 := pItems_^.iCharPos; text := Copy(s, p1 + 1, p2 - p1); run := TfrxPDFRun.Create(text, a); result.Add(run); end; finally FreeMemory(pItems); end; end; function TfrxPDFFont.Layout(runs: TList; rtl: boolean): TList; var pbLevel, p1: PByte; piVisualToLogical, piVT: PInteger; i: Integer; run: TfrxPDFRun; begin pbLevel := GetMemory(runs.Count); piVT := GetMemory(SizeOf(Integer) * runs.Count); try p1 := pbLevel; for i := 0 to runs.Count - 1 do begin p1^ := byte(TfrxPDFRun(runs[i]).analysis.s and $1F); Inc(p1); end; ScriptLayout(runs.Count, pbLevel, piVT, nil); result := TList.Create; piVisualToLogical := piVT; for i := 0 to runs.Count - 1 do begin run := TfrxPDFRun(runs[piVisualToLogical^]); result.Add(run); Inc(piVisualToLogical); end; finally FreeMemory(pbLevel); FreeMemory(piVT); runs.Free; end; end; procedure TfrxPDFFont.FillOutlineTextMetrix; var i: Cardinal; begin tempBitmap.Canvas.Lock; try tempBitmap.Canvas.Font.Assign(SourceFont); i := GetOutlineTextMetrics(tempBitmap.Canvas.Handle, 0, nil); if i = 0 then begin tempBitmap.Canvas.Font.Name := 'Arial'; i := GetOutlineTextMetrics(tempBitmap.Canvas.Handle, 0, nil); end; if i <> 0 then begin TextMetric := GetMemory(i); if TextMetric <> nil then GetOutlineTextMetricsA(tempBitmap.Canvas.Handle, i, TextMetric); end; finally tempBitmap.Canvas.Unlock; end; end; procedure TfrxPDFFont.GetFontFile; begin tempBitmap.Canvas.Lock; try tempBitmap.Canvas.Font.Assign(SourceFont); FontDataSize := GetFontData(tempBitmap.Canvas.Handle, 0, 0, nil, 1); if FontDataSize > 0 then begin FontData := GetMemory(FontDataSize); if FontData <> nil then GetFontData(tempBitmap.Canvas.Handle, 0, 0, FontData, FontDataSize) else FontDataSize := 0; end; finally tempBitmap.Canvas.Unlock; end; end; function TfrxPDFFont.RemapString(str: WideString; rtl: Boolean): WideString; var maxGlyphs: Integer; g, g_: PWord; w, w_: PInteger; actualLength: Integer; i, j: Integer; c: Word; wc: WideChar; begin result := ''; maxGlyphs := Length(str) * 3; g := GetMemory(SizeOf(Word) * maxGlyphs); w := GetMemory(SizeOf(Integer) * maxGlyphs); tempBitmap.Canvas.Lock; try tempBitmap.Canvas.Font.Assign(SourceFont); actualLength := GetGlyphIndices(tempBitmap.Canvas.Handle, str, g, w, rtl); g_ := g; w_ := w; for i := 0 to actualLength - 1 do begin c := g_^; if UsedAlphabet.IndexOf(Pointer(c)) = -1 then begin UsedAlphabet.Add(Pointer(c)); Widths.Add(Pointer(w_^)); if actualLength = Length(str) then begin if rtl then j := actualLength - i else j := i + 1; UsedAlphabetUnicode.Add(Pointer(str[j])); end else UsedAlphabetUnicode.Add(Pointer(TextMetric^.otmTextMetrics.tmDefaultChar)); end; wc := WideChar(c); result := result + wc; Inc(g_); Inc(w_); end; finally FreeMemory(g); FreeMemory(w); tempBitmap.Canvas.Unlock; end; end; function TfrxPDFFont.GetFontName: AnsiString; var s: AnsiString; function HexEncode7F(Str: WideString): AnsiString; var s: AnsiString; Index, Len: Integer; begin s := ''; Len := Length(Str); Index := 0; while Index < Len do begin Index := Index + 1; if Byte(Str[Index]) > $7F then s := s + '#' + AnsiString(IntToHex(Byte(Str[Index]), 2)) else s := s + AnsiString(Str[Index]); end; Result := s; end; begin {$IFDEF Delphi12} Result := AnsiString(SourceFont.Name); Result := StringReplace(Result, AnsiString(' '), AnsiString('#20'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('('), AnsiString('#28'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString(')'), AnsiString('#29'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('%'), AnsiString('#25'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('<'), AnsiString('#3C'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('>'), AnsiString('#3E'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('['), AnsiString('#5B'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString(']'), AnsiString('#5D'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('{'), AnsiString('#7B'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('}'), AnsiString('#7D'), [rfReplaceAll]); Result := StringReplace(Result, AnsiString('/'), AnsiString('#2F'), [rfReplaceAll]); {$ELSE} Result := SourceFont.Name; Result := StringReplace(Result, ' ', '#20', [rfReplaceAll]); Result := StringReplace(Result, '(', '#28', [rfReplaceAll]); Result := StringReplace(Result, ')', '#29', [rfReplaceAll]); Result := StringReplace(Result, '%', '#25', [rfReplaceAll]); Result := StringReplace(Result, '<', '#3C', [rfReplaceAll]); Result := StringReplace(Result, '>', '#3E', [rfReplaceAll]); Result := StringReplace(Result, '[', '#5B', [rfReplaceAll]); Result := StringReplace(Result, ']', '#5D', [rfReplaceAll]); Result := StringReplace(Result, '{', '#7B', [rfReplaceAll]); Result := StringReplace(Result, '}', '#7D', [rfReplaceAll]); Result := StringReplace(Result, '/', '#2F', [rfReplaceAll]); {$ENDIF} s := ''; if fsBold in SourceFont.Style then s := s + 'Bold'; if fsItalic in SourceFont.Style then s := s + 'Italic'; if s <> '' then Result := Result + ',' + s; {$IFDEF Delphi12} Result := HexEncode7F(String(Result)); {$ELSE} Result := HexEncode7F(Result); {$ENDIF} end; { TfrxPDFRun } constructor TfrxPDFRun.Create(t: WideString; a: SCRIPT_ANALYSIS); begin text := t; analysis := a; end; initialization pdfCS := TCriticalSection.Create; finalization pdfCS.Free; end.