unit vcl24NSPDFViewer;

interface

uses
  System.SysUtils, System.Variants,
  System.Classes, System.Types,
  System.SyncObjs,
  Winapi.Windows, Winapi.Messages,
  Vcl.Graphics, Vcl.Controls, Vcl.Forms,
  Vcl.Dialogs, Vcl.StdCtrls, Vcl.ExtCtrls,
  Generics.Collections,

  IdComponent, IdHTTP;

const
  WM_DONETHREAD = WM_USER + 1;
  WM_RENDERBITMAP = WM_USER + 2;
  WM_RELEASEBITMAP = WM_USER + 3;
  WM_DOWNLOADFILE = WM_USER + 4;

type
  TPDFPointer = record end;
  TPDFDocument = ^TPDFPointer;
  TPDFPage = ^TPDFPointer;

const
  PDF_LIBRARY_NAME = 'PDFIUM.DLL';

type
  TPDFClosePage = procedure(APage: Pointer); stdcall;
  TPDFInitLibrary = procedure; stdcall;
  TPDFDestroyLibrary = procedure; stdcall;
  TPDFGetPageCount = function(ADocument: Pointer): Integer; stdcall;
  TPDFCloseDocument = procedure(ADocument: Pointer); stdcall;
  TPDFLoadMemDocument = function(ABuffer: Pointer; ASize: Integer;
    APassword: PAnsiChar): Pointer; stdcall;
  TPDFGetPageSizeByIndex = function(ADocument: Pointer; APage: Integer;
    var AWidth, AHeight: Double): Integer; stdcall;
  TPDFGetPageWidth = function(APage: Pointer): Double; stdcall;
  TPDFGetPageHeight = function(APage: Pointer): Double; stdcall;
  TPDFRenderPage = procedure(ADC: HDC; APage: Pointer;
    ALeft, ATop, AWidth, AHeight, ARotate, AFlags: Integer); stdcall;
  TPDFLoadPage = function(ADocument: Pointer; APage: Integer): TPDFPage; stdcall;

  T24NSDocumentPage = class;
  T24NSPDFViewer = class;


  T24NSDownloader = class(TIdHTTP);

  T24NSHelperThread = class(TThread)
  private
    FViewer: T24NSPDFViewer;
    FMessageLoop: Boolean;
  protected
    procedure Execute; override;
    procedure Invalidate;
    procedure RenderBitmap(const AMsg: TMsg);
    procedure ReleaseBitmap(const AMsg: TMsg);
  public
    constructor Create(AViewer: T24NSPDFViewer);
    procedure Done;
    procedure WaitLooping;
  end;

  TPDFLibrary = packed record
  public
    ClosePage: TPDFClosePage;
    InitLibrary: TPDFInitLibrary;
    RenderPage: TPDFRenderPage;
    LoadPage: TPDFLoadPage;
    DestroyLibrary: TPDFDestroyLibrary;
    GetPageSizeByIndex: TPDFGetPageSizeByIndex;
    GetPageCount: TPDFGetPageCount;
    CloseDocument: TPDFCloseDocument;
    GetPageWidth: TPDFGetPageWidth;
    GetPageHeight: TPDFGetPageHeight;
    LoadMemDocument: TPDFLoadMemDocument;
  end;

  T24NSDocumentEngine = class(TObject)
  strict private
    FPDFLibrary: TPDFLibrary;
    FDocument: TPDFDocument;
    FMemoryBuffer: TMemoryStream;
    FModule: HMODULE;
    procedure FreeDocument;
  public
    constructor Create;
    destructor Destroy; override;
    procedure LoadFromStream(AStream: TStream);
    function Initialized: Boolean; inline;
    function PageCount: Integer; inline;
    property PDFLibrary: TPDFLibrary read FPDFLibrary;
    property Document: TPDFDocument read FDocument;
  end;

  T24NSDocumentPage = class(TObject)
  strict private
    FEngine: T24NSDocumentEngine;
    FBitmap: TBitmap;
    FIndex: Integer;
    FWidth: Double;
    FHeight: Double;
    FBitmapRendered: Boolean;
    FTimer: TTimer;
    FViewer: T24NSPDFViewer;
    FBlendValue: Integer;
    procedure TimerTick(Sender: TObject);
    procedure UpdatePage;
  public
    constructor Create(AViewer: T24NSPDFViewer; AIndex: Integer);
    destructor Destroy; override;
    function RenderedHeight(AWidth: Integer): Integer;
    procedure ReleaseBitmap;
    procedure RenderBitmap(AWidth: Integer);
    procedure ResetTimer; inline;
    procedure PrereleaseBitmap; inline;
    property BlendValue: Integer read FBlendValue;
    property Timer: TTimer read FTimer;
    property BitmapRendered: Boolean read FBitmapRendered;
    property Width: Double read FWidth;
    property Height: Double read FHeight;
    property Bitmap: TBitmap read FBitmap;
  end;

  T24NSDocumentPages = class(TObject)
  strict private
    FPages: TObjectList<T24NSDocumentPage>;
    FEngine: T24NSDocumentEngine;
    FPagesHeight: Integer;
    FViewer: T24NSPDFViewer;
  protected
    function GetCount: Integer; inline;
    procedure PreparePages;
  public
    constructor Create(AViewer: T24NSPDFViewer);
    destructor Destroy; override;
    function Page(AIndex: Integer): T24NSDocumentPage; inline;
    function First: T24NSDocumentPage; inline;
    function Last: T24NSDocumentPage; inline;
    property Count: Integer read GetCount;
    property PagesHeight: Integer read FPagesHeight;
  end;

  T24NSPDFViewer = class(TGraphicControl)
  strict private
    FEngine: T24NSDocumentEngine;
    FPages: T24NSDocumentPages;
    FDownloader: T24NSDownloader;
    FHelperThread: T24NSHelperThread;
    FViewOffset: Integer;
    FBlendFunction: TBlendFunction;
    FOnReady: TNotifyEvent;
    FDocumentLoaded: Boolean;
    FDocumentLoading: Boolean;
    FDocumentProgress: Integer;
    FBeginDocument: Boolean;
    FEndDocument: Boolean;
    FPainting: Boolean;
  protected
    procedure ReleaseBitmap(APageIndex: Integer; ABitmap: TBitmap); inline;
    procedure RenderBitmap(APageIndex: Integer; ABitmap: TBitmap); inline;
    procedure DownloadWork(Sender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
    procedure Paint; override;
    property Engine: T24NSDocumentEngine read FEngine;
    property Pages: T24NSDocumentPages read FPages;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure AfterConstruction; override;
    procedure ScrollBy(ADelta: Integer);
    procedure Ready;
    procedure LoadFromFile(const AFileName: string);
    procedure LoadFromURL(const AURL: string);
    procedure LoadFromStream(AStream: TStream);
    property OnReady: TNotifyEvent read FOnReady write FOnReady;
    property Painting: Boolean read FPainting;
    property EndDocument: Boolean read FEndDocument;
    property BeginDocument: Boolean read FBeginDocument;
  end;

implementation

resourcestring
  RST_PDFIUMNOTLOADED = 'PDFIUM.DLL IS NOT LOADED CORRECTLY';


const
  DEF_FONT_SIZE = 38;
  DEF_FONT_NAME = 'Impact';
  DEF_FONT_COLOR = $DADADA;
  DEF_BLENDING_STEP = 32;
  DEF_BLENDING_INTERVAL = 32;

{ T24NSDocumentEngine }

constructor T24NSDocumentEngine.Create;
begin
  inherited Create;
  FMemoryBuffer := nil;
  FModule := SafeLoadLibrary(PDF_LIBRARY_NAME);
  with FPDFLibrary do
  begin
    if FModule = 0 then
      raise Exception.CreateRes(@RST_PDFIUMNOTLOADED);
    InitLibrary := GetProcAddress(FModule, '_FPDF_InitLibrary@0');
    DestroyLibrary := GetProcAddress(FModule, '_FPDF_DestroyLibrary@0');
    RenderPage := GetProcAddress(FModule, '_FPDF_RenderPage@32');
    LoadPage := GetProcAddress(FModule, '_FPDF_LoadPage@8');
    GetPageWidth := GetProcAddress(FModule, '_FPDF_GetPageWidth@4');
    GetPageHeight := GetProcAddress(FModule, '_FPDF_GetPageHeight@4');
    GetPageCount := GetProcAddress(FModule, '_FPDF_GetPageCount@4');
    LoadMemDocument := GetProcAddress(FModule, '_FPDF_LoadMemDocument@12');
    CloseDocument := GetProcAddress(FModule, '_FPDF_CloseDocument@4');
    ClosePage := GetProcAddress(FModule, '_FPDF_ClosePage@4');
    GetPageSizeByIndex := GetProcAddress(FModule, '_FPDF_GetPageSizeByIndex@16');
    InitLibrary
  end
end;

destructor T24NSDocumentEngine.Destroy;
begin
  if Initialized then
  begin
    FreeDocument;
    FreeAndNil(FMemoryBuffer);
    FPDFLibrary.DestroyLibrary;
    FreeLibrary(FModule)
  end;
  inherited Destroy
end;

procedure T24NSDocumentEngine.FreeDocument;
begin
  if FDocument <> nil then
    FPDFLibrary.CloseDocument(FDocument);
  FDocument := nil;
  FreeAndNil(FMemoryBuffer);
  FMemoryBuffer := TMemoryStream.Create
end;

function T24NSDocumentEngine.Initialized: Boolean;
begin
  Result := FModule <> 0
end;

procedure T24NSDocumentEngine.LoadFromStream(AStream: TStream);
begin
  if Initialized then
  begin
    FreeDocument;
    if AStream.Size > 0 then
      try
        FMemoryBuffer.LoadFromStream(AStream);
        with FMemoryBuffer, FPDFLibrary do
          FDocument := LoadMemDocument(Memory, Size, nil)
      except
        FreeDocument
      end
  end
end;

function T24NSDocumentEngine.PageCount: Integer;
begin
  Result := 0;
  if Initialized and (FDocument <> nil) then
    Result := FPDFLibrary.GetPageCount(FDocument)
end;

{ T24NSPDFViewer }

procedure T24NSPDFViewer.AfterConstruction;
begin
  inherited AfterConstruction;
  FHelperThread.WaitLooping
end;

constructor T24NSPDFViewer.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FViewOffset := 0;
  FBeginDocument := False;
  FEndDocument := False;
  FDocumentLoaded := False;
  FDocumentLoading := False;
  FPainting := False;
  FDocumentProgress := 0;
  FBlendFunction.BlendOp := AC_SRC_OVER;
  FBlendFunction.BlendFlags := 0;
  FBlendFunction.SourceConstantAlpha := 255;
  FBlendFunction.AlphaFormat := 0;
  Color := clWhite;
  FEngine := T24NSDocumentEngine.Create;
  FPages := T24NSDocumentPages.Create(Self);
  FHelperThread := T24NSHelperThread.Create(Self);

  FDownloader := T24NSDownloader.Create(Self);
  FDownloader.AllowCookies := True;
  FDownloader.HandleRedirects := True
end;

destructor T24NSPDFViewer.Destroy;
begin
  FHelperThread.Done;
  FreeAndNil(FHelperThread);
  FreeAndNil(FPages);
  FreeAndNil(FEngine);
  inherited Destroy
end;


procedure T24NSPDFViewer.DownloadWork(Sender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
var
  ContentLength: Int64;
begin
  ContentLength := FDownloader.Response.ContentLength;
  FDocumentProgress := 100 * AWorkCount div ContentLength;
  TWinControl(Owner).Repaint
end;

procedure T24NSPDFViewer.LoadFromFile(const AFileName: string);
var
  Stream: TStream;
begin
  Stream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite);
  try
    LoadFromStream(Stream)
  finally
    FreeAndNil(Stream)
  end
end;

procedure T24NSPDFViewer.LoadFromStream(AStream: TStream);
begin
  try
    if AStream.Size = 0 then
      Abort;
    AStream.Position := 0;
    FEngine.LoadFromStream(AStream);
    FPages.PreparePages;
    Ready;
    Repaint
  except
    FDocumentLoaded := False
  end
end;


procedure T24NSPDFViewer.LoadFromURL(const AURL: string);
var
  Stream: TStream;
begin
  Stream := TMemoryStream.Create;
  FDocumentLoading := True;
  try
    FDownloader.OnWork := DownloadWork;
    FDocumentLoaded := False;
    TWinControl(Owner).Repaint;
    try
      FDownloader.Get(AURL, Stream);
      FDocumentLoading := False;
      LoadFromStream(Stream)
    except
      Ready
    end
  finally
    FDownloader.OnWork := nil;
    FDocumentProgress := 0;
    FreeAndNil(Stream)
  end
end;

procedure T24NSPDFViewer.Paint;
var
  X, Y: Integer;
  R: TRect;
  RealHeight: Integer;
  I: Integer;
  Progress: string;
  Size: TSize;
begin
  FPainting := True;
  try
    with Canvas do
    begin
      Brush.Style := bsSolid;
      Brush.Color := Color;
      FillRect(ClientRect)
    end;
    if FDocumentLoading then
    begin
      Progress := Concat(FDocumentProgress.ToString, '%');
      with Canvas.Font do
      begin
        Name := DEF_FONT_NAME;
        Size := DEF_FONT_SIZE;
        Color := DEF_FONT_COLOR
      end;
      Size := Canvas.TextExtent(Progress);
      X := (ClientWidth - Size.Width) div 2;
      Y := (ClientHeight - Size.Height) div 2;
      Canvas.TextOut(X, Y, Progress)
    end;
    if FDocumentLoaded then
    begin
      X := 0;
      Y := 0;
      Dec(Y, FViewOffset);
      for I := 0 to Pred(FPages.Count) do
      begin
        RealHeight := FPages.Page(I).RenderedHeight(ClientWidth);
        if ((Y + RealHeight) > 0) and (Y < ClientHeight) then
        begin
          if not FPages.Page(I).BitmapRendered then
            RenderBitmap(I, nil)
          else
          begin
            R := Rect(X, Y, ClientWidth, Y + RealHeight);
            if FPages.Page(I).Timer.Enabled then
            begin
              FBlendFunction.SourceConstantAlpha := FPages.Page(I).BlendValue;
              AlphaBlend(Canvas.Handle, X, Y, ClientWidth, RealHeight,
                FPages.Page(I).Bitmap.Canvas.Handle,
                0, 0, ClientWidth, RealHeight, FBlendFunction)
            end
            else
              BitBlt(Canvas.Handle, X, Y, ClientWidth, RealHeight,
                FPages.Page(I).Bitmap.Canvas.Handle, 0, 0, SRCCOPY)
          end
        end
        else
        begin
          if FPages.Page(I).BitmapRendered then
          begin
            FPages.Page(I).PrereleaseBitmap;
            ReleaseBitmap(I, FPages.Page(I).Bitmap)
          end;
        end;
        Inc(Y, RealHeight)
      end;
{$IFDEF 24NSDEBUG}
      Canvas.TextOut(0, 0, FViewOffset.ToString)
{$ENDIF}
    end
  finally
    FPainting := False
  end
end;

procedure T24NSPDFViewer.Ready;
begin
  FDocumentLoading := False;
  FDocumentLoaded := True;
  FBeginDocument := True;
  FEndDocument := False;
  FViewOffset := 0;
  if Assigned(FOnReady) then
    FOnReady(Self);
  Invalidate
end;

procedure T24NSPDFViewer.ReleaseBitmap(APageIndex: Integer; ABitmap: TBitmap);
begin
  PostThreadMessage(FHelperThread.ThreadID, WM_RELEASEBITMAP, WPARAM(APageIndex), LPARAM(ABitmap))
end;

procedure T24NSPDFViewer.RenderBitmap(APageIndex: Integer; ABitmap: TBitmap);
begin
  PostThreadMessage(FHelperThread.ThreadID, WM_RENDERBITMAP, WPARAM(APageIndex), LPARAM(ClientWidth))
end;

procedure T24NSPDFViewer.ScrollBy(ADelta: Integer);
var
  Y: Integer;
begin
  FBeginDocument := False;
  FEndDocument := False;
  if FDocumentLoaded then
  begin
    Inc(FViewOffset, ADelta);
    if FViewOffset <= 0 then
      FViewOffset := 0;
    Y := Pages.PagesHeight - ClientHeight;
    if Y < 0 then
      Y := 0;
    if FViewOffset > Y then
      FViewOffset := Y;
    FBeginDocument := FViewOffset = 0;
    FEndDocument := FViewOffset = Y;
    Invalidate
  end
end;

{ T24NSDocumentPages }

constructor T24NSDocumentPages.Create(AViewer: T24NSPDFViewer);
begin
  inherited Create;
  FViewer := AViewer;
  FEngine := AViewer.Engine;
  FPagesHeight := 0;
  FPages := TObjectList<T24NSDocumentPage>.Create(True)
end;

destructor T24NSDocumentPages.Destroy;
begin
  FreeAndNil(FPages);
  inherited Destroy
end;

function T24NSDocumentPages.GetCount: Integer;
begin
  Result := FPages.Count
end;

function T24NSDocumentPages.First: T24NSDocumentPage;
begin
  if Count = 0 then
    Exit(nil);
  Exit(Page(0))
end;

function T24NSDocumentPages.Last: T24NSDocumentPage;
begin
  if Count = 0 then
    Exit(nil);
  Exit(Page(Pred(Count)))
end;

procedure T24NSDocumentPages.PreparePages;
var
  Page: T24NSDocumentPage;
  I: Integer;
  X: Integer;
begin
  FPagesHeight := 0;
  FPages.Clear;
  X := FViewer.ClientWidth;
  for I := 0 to Pred(FEngine.PageCount) do
  begin
    Page := T24NSDocumentPage.Create(FViewer, I);
    FPages.Add(Page);
    FPagesHeight := FPagesHeight + Page.RenderedHeight(X)
  end
end;

function T24NSDocumentPages.Page(AIndex: Integer): T24NSDocumentPage;
begin
  Result := FPages.List[AIndex]
end;

{ T24NSDocumentPage }

constructor T24NSDocumentPage.Create(AViewer: T24NSPDFViewer; AIndex: Integer);
begin
  inherited Create;
  FBitmap := nil;
  FViewer := AViewer;
  FIndex := AIndex;
  FBitmapRendered := False;
  FBlendValue := 0;
  FEngine := AViewer.Engine;
  FTimer := TTimer.Create(nil);
  FTimer.OnTimer := TimerTick;
  FTimer.Enabled := False;
  FTimer.Interval := DEF_BLENDING_INTERVAL;
  UpdatePage;
  ReleaseBitmap
end;

destructor T24NSDocumentPage.Destroy;
begin
  FreeAndNil(FTimer);
  FreeAndNil(FBitmap);
  inherited Destroy
end;

procedure T24NSDocumentPage.PrereleaseBitmap;
begin
  ResetTimer;
  FBitmapRendered := False
end;

procedure T24NSDocumentPage.UpdatePage;
begin
  with FEngine, FEngine.PDFLibrary do
    GetPageSizeByIndex(Document, FIndex, FWidth, FHeight)
end;

procedure T24NSDocumentPage.ReleaseBitmap;
begin
  FBitmapRendered := False;
  FreeAndNil(FBitmap);
  FBitmap := TBitmap.Create
end;

procedure T24NSDocumentPage.RenderBitmap(AWidth: Integer);
var
  DisplayWidth: Integer;
  DisplayHeight: Integer;
  Page: TPDFPage;
begin
  if not FBitmapRendered then
  begin
    Page := FEngine.PDFLibrary.LoadPage(FEngine.Document, FIndex);
    try
      FBitmap.Canvas.Lock;
      try
        DisplayWidth := AWidth;
        DisplayHeight := RenderedHeight(DisplayWidth);
        FBitmap.SetSize(DisplayWidth, DisplayHeight);
        FEngine.PDFLibrary.RenderPage(FBitmap.Canvas.Handle,
          Page, 0, 0, DisplayWidth, DisplayHeight, 0, 0)
      finally
        FBitmap.Canvas.Unlock
      end;
      FBlendValue := 0;
      FBitmapRendered := True;
      Timer.Enabled := True
    finally
      FEngine.PDFLibrary.ClosePage(Page)
    end
  end
end;

function T24NSDocumentPage.RenderedHeight(AWidth: Integer): Integer;
begin
  Result := Round(Height * (AWidth / Width))
end;

procedure T24NSDocumentPage.ResetTimer;
begin
  FTimer.Enabled := False;
  FBlendValue := 0
end;

procedure T24NSDocumentPage.TimerTick(Sender: TObject);
begin
  Inc(FBlendValue, DEF_BLENDING_STEP);
  if FBlendValue >= 255 then
    ResetTimer;
  FViewer.Invalidate
end;

{ T24NSHelperThread }

constructor T24NSHelperThread.Create(AViewer: T24NSPDFViewer);
begin
  inherited Create(False);
  Priority := tpLowest;
  FViewer := AViewer;
  FreeOnTerminate := False
end;

procedure T24NSHelperThread.WaitLooping;
begin
  while not FMessageLoop do
    SwitchToThread
end;

procedure T24NSHelperThread.Execute;
var
  Msg: TMsg;

  function HandleMessage: Boolean; near;

    function NeedHandleMessage: Boolean; near;
    begin
      Result := (Msg.Message >= WM_DONETHREAD)
        and (Msg.Message <= WM_DOWNLOADFILE)
    end;

  begin
    Result := NeedHandleMessage;
    if Result then
      case Msg.Message of
        WM_DONETHREAD:
          Terminate;
        WM_RELEASEBITMAP:
          ReleaseBitmap(Msg);
        WM_RENDERBITMAP:
          RenderBitmap(Msg)
      end
  end;

  function ProcessMessage: Boolean; near;
  begin
    if PeekMessage(Msg, 0, 0, 0, PM_NOREMOVE) then
    begin
      Result := PeekMessage(Msg, 0, 0, 0, PM_REMOVE);
      if Result then
      begin
        if not HandleMessage then
          if not Terminated then
          begin
            TranslateMessage(Msg);
            DispatchMessage(Msg)
          end
      end
    end
    else
      Result := False
  end;

begin
  FMessageLoop := True;
  try
    while not Terminated do
      if not ProcessMessage then
        WaitMessage
  finally
    FMessageLoop := False
  end
end;

procedure T24NSHelperThread.Invalidate;
begin
  if FViewer.Owner is TWinControl then
    TWinControl(FViewer.Owner).Invalidate
end;

procedure T24NSHelperThread.ReleaseBitmap;
begin
  FViewer.Pages.Page(AMsg.wParam).ReleaseBitmap
end;

procedure T24NSHelperThread.RenderBitmap;
begin
  while FViewer.Painting do
    SwitchToThread;
  FViewer.Pages.Page(AMsg.wParam).RenderBitmap(AMsg.lParam)
end;

procedure T24NSHelperThread.Done;
begin
  if not Suspended and not Terminated then
    PostThreadMessage(ThreadID, WM_DONETHREAD, 0, 0)
end;

end.