usealpdf.pas

给PDF文件加盖印章或背景

{*
* Copyright (c) 2007 ,北京量子伟业时代信息技术有限公司开发部
* All rights reserved.
*
* 文件名称：uSealPDF
* 文件标识：
* 摘    要：归档章类
*
* 当前版本：1.0
* 作    者：占国太
* 完成日期：2008-5-29
*}


unit uSealPDF;

interface
uses
  Windows, SysUtils, StrUtils, Classes,PdfDoc, PdfTypes, PdfFonts;

type
  PPdfObj = ^TPdfObj;
  TPdfObj = record
    number,
      offset: integer;
    filePtr: pchar;
  end;
  TPdfSeal=class(TObject)
   private
    FsParam1: string;
    FsParam2: string;
    FsParam3: string;
    FsParam4: string;
    FsParam5: string;
    FsParam6: string;
    Faction:string;
    FallowParams:string;
    FownerParam:string;
    FuserParam: string;
    tmpPath:string;
    PdfTkPath:string;
    FiPosition: integer;
    function GetPdfPageCount(const filename: string): integer;
    function CreateTempPDF(P1, P2, P3, P4, P5, P6: string; var TempFile: string; iPos: integer = 2): boolean;
  public
    constructor Create;virtual;
    destructor Destroy; override;
    property sParam1: string read FsParam1 write FsParam1;
    property sParam2: string read FsParam2 write FsParam2;
    property sParam3: string read FsParam3 write FsParam3;
    property sParam4: string read FsParam4 write FsParam4;
    property sParam5: string read FsParam5 write FsParam5;
    property sParam6: string read FsParam6 write FsParam6;
    property action:string  read Faction write Faction;
    property allowParams:string read FallowParams write FallowParams;
    property ownerParam:string read FownerParam write FownerParam;
    property userParam: string read FuserParam write  FuserParam;
    property iPosition:integer read FiPosition write FiPosition;
    procedure DeleteAllTmpPdfFiles;
    function DoSealOk(PdfFileName,NewPDF:string): boolean;
  end;

implementation

function GetTempDirectory: string;
var
  tempFolder: array[0..MAX_PATH] of char;
begin
  if GetTempPath(MAX_PATH, @tempFolder) = 0 then
    raise Exception.Create('GetTempPath: Invalid temp path')
  else
    result := tempFolder;
end;
function ExtractRes(ResType, ResName, ResNewName: string): boolean;
var
  Res: TResourceStream;
begin
  if not FileExists(ResNewName) then
  begin
    Res := TResourceStream.Create(Hinstance, Resname, Pchar(ResType));
    Res.SavetoFile(ResNewName);
    Res.Free;
  end;
  Result := FileExists(ResNewName);
end;

const
  NEVER_GIVE_UP = 0;

function WinExecAndWait32(const DosCommand: string;
  ShowWindow, GiveUpTimeOutSecs: Word; out textOutput: string): DWord;
const
  BufferSize = 8192;
var
  StartUpInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  OutputReadPipeHdl, OutputWritePipeHdl: THandle;
  SecAttribs: TSecurityAttributes;
  Buffer: PChar;
  timeCnt, BytesRead, BytesAvailable, WaitResult: DWord;
  PipeCreated, ProcessCreated: boolean;
begin
  //nb: 1. The max command line length for CreateProcess() is 32767 characters.
  Result := DWORD(-1); //ie result when unable to create process
  if GiveUpTimeOutSecs = NEVER_GIVE_UP then
    GiveUpTimeOutSecs := $FFFF; //(ie about 18hrs so not quite never :))
  SecAttribs.nLength := SizeOf(TSecurityAttributes);
  SecAttribs.bInheritHandle := true;
  SecAttribs.lpSecurityDescriptor := nil;
  PipeCreated := CreatePipe(OutputReadPipeHdl,
    OutputWritePipeHdl, @SecAttribs, BufferSize);
  StartUpInfo.cb := Sizeof(StartUpInfo);
  StartUpInfo.wShowWindow := ShowWindow;
  Buffer := AllocMem(BufferSize + 1);
  try
    if PipeCreated then
    begin
      fillChar(startUpInfo, sizeof(startUpInfo), 0);
      startUpInfo.dwFlags := STARTF_USESHOWWINDOW or STARTF_USESTDHANDLES;
      startUpInfo.hStdInput := 0;
      startUpInfo.hStdOutput := OutputWritePipeHdl;
      startUpInfo.hStdError := OutputWritePipeHdl;
      ProcessCreated := CreateProcess(nil, PChar(DosCommand),
        @SecAttribs, @SecAttribs, true, NORMAL_PRIORITY_CLASS,
        nil, nil, startUpInfo, ProcessInfo);
      textOutput := '';
    end else
    begin
      startUpInfo.dwFlags := STARTF_USESHOWWINDOW;
      ProcessCreated := CreateProcess(nil, PChar(DosCommand),
        nil, nil, false, NORMAL_PRIORITY_CLASS or CREATE_NEW_CONSOLE,
        nil, nil, startUpInfo, ProcessInfo);
    end;

    if ProcessCreated then
    begin
      timeCnt := 0;
      repeat
        WaitResult := WaitForSingleObject(ProcessInfo.hProcess, 100);

        if PipeCreated then
        begin
          //nb: a full pipe buffer would cause an endless loop ...
          if not PeekNamedPipe(OutputReadPipeHdl,
            nil, 0, nil, @BytesAvailable, nil) then break;
          if (BytesAvailable > 0) then
          begin
            //Interestingly, it appears that if the default pipe buffer is larger
            //that that supplied in CreatePipe(), then the default size is used.
            BytesRead := 0;
            if BytesAvailable > BufferSize then
              ReadFile(OutputReadPipeHdl, Buffer[0], BufferSize, BytesRead, nil)
            else
              ReadFile(OutputReadPipeHdl, Buffer[0], BytesAvailable, BytesRead, nil);
            Buffer[BytesRead] := #0;
            OemToAnsi(Buffer, Buffer);
            textOutput := textOutput + Buffer;
          end;
        end;
        //Application.ProcessMessages;
        inc(timeCnt, 100);
      until (WaitResult <> WAIT_TIMEOUT) or (timeCnt > GiveUpTimeOutSecs * 1000);

      if not GetExitCodeProcess(ProcessInfo.hProcess, Result)
        and (result = STILL_ACTIVE) then
        TerminateProcess(ProcessInfo.hProcess, result);

      CloseHandle(ProcessInfo.hProcess);
      CloseHandle(ProcessInfo.hThread);
    end;

    if PipeCreated then
    begin
      CloseHandle(OutputWritePipeHdl);
      CloseHandle(OutputReadPipeHdl);
    end;
  finally
    FreeMem(Buffer);
  end;
end;

function MakeGUID: string;
var
  aGuid: TGUID;
begin
  CreateGuid(aGuid);
  Result := GUIDToString(aGuid);
  Delete(Result, 1, 1);
  Delete(Result, length(Result), 1);
  Result := AnsiReplaceText(Result, '-', '');
end;

{TPdfSeal}
procedure TPdfSeal.DeleteAllTmpPdfFiles;
var
  i: integer;
  sr: TSearchRec;
begin
  i := FindFirst(tmpPath + '*.pdf', faAnyFile, sr);
  while i = 0 do
  begin
    SetFileAttributes(pchar(tmpPath + sr.Name), 0); //remove read-only etc
    DeleteFile(tmpPath + sr.Name);
    i := FindNext(sr);
  end;
  FindClose(sr);
end;

function TPdfSeal.GetPdfPageCount(const filename: string): integer;
var
  ms: TMemoryStream;
  k, cnt, pagesNum, rootNum: integer;
  p, p2: pchar;
  PdfObj: PPdfObj;
  PdfObjList: TList;

  //Summary of steps taken to parse PDF file for page count :-
  //1. Locate 'startxref' at end of file
  //2. get 'xref' offset and go to xref table
  //3. fill my pdfObj List with object numbers and offsets
  //4. handle subsections within xref table.
  //5. read 'trailer' section at end of each xref
  //6. store 'Root' object number if found in 'trailer'
  //7. if 'Prev' xref found in 'trailer' - loop back to step 2
  //8. locate Root in my full pdfObj List
  //9. locate 'Pages' object from Root
  //10. get Count from Pages.

  function GetNumber(out num: integer): boolean;
  var
    tmpStr: string;
  begin
    tmpStr := '';
    while p^ < #33 do inc(p); //skip leading CR,LF & SPC
    while (p^ in ['0'..'9']) do
    begin
      tmpStr := tmpStr + p^;
      inc(p);
    end;
    result := tmpStr <> '';
    if not result then exit;
    num := strtoint(tmpStr);
  end;

  function IsString(const str: string): boolean;
  var
    len: integer;
  begin
    len := length(str);
    result := CompareMem(p, pchar(str), len);
    inc(p, len);
  end;

  function FindStrInDict(const str: string): boolean;
  var
    nestLvl: integer;
    str1: char;
  begin
    //06-Mar-07: bugfix- added nested dictionary support
    //nb: PDF 'dictionaries' start with '<<' and terminate with '>>'
    result := false;
    nestLvl := 0;
    str1 := str[1];
    while not result do
    begin
      while not (p^ in ['>', '<', str1]) do inc(p);
      if (p^ = '<') then
      begin
        if (p + 1)^ = '<' then begin inc(nestLvl); inc(p); end;
      end
      else if (p^ = '>') then
      begin
        if (p + 1)^ = '>' then
        begin
          dec(nestLvl);
          inc(p);
          if nestLvl <= 0 then exit;
        end
      end else
      begin
        result := (nestLvl < 2) and IsString(str);
      end;
      inc(p);
    end;
  end;

begin
  //on error return -1 as page count
  result := -1;
  try
    ms := TMemoryStream.Create;
    PdfObjList := TList.Create;
    //application.ProcessMessages;
    try
      ms.LoadFromFile(filename);

      //find 'startxref' ignoring '%%EOF'
      p := pchar(ms.Memory) + ms.Size - 5;
      //21-Jun-05: bugfix
      //sometimes rubbish is appended to the pdf so
      //look deeper for 'startxref'
      p2 := pchar(ms.Memory);
      repeat
        while (p > p2) and (p^ <> 'f') do dec(p);
        if (p = p2) then exit;
        if StrLComp((p - 8), 'startxref', 9) = 0 then break;
        dec(p);
      until false;
      inc(p);

      rootNum := -1; //ie flag not yet found

      //xref offset ==> k
      if not GetNumber(k) then exit;
      p := pchar(ms.Memory) + k + 4;

      while true do //top of loop  //////////////////////////////
      begin
        //get base object number ==> k
        if not GetNumber(k) then exit;
        //get object count ==> cnt
        if not GetNumber(cnt) then exit;
        //07-Mar-07: bugfix
        //it is possible to have 0 objects in a section
        while p^ < #33 do inc(p); //skip CR, LF, SPC

        //p2 := p; //for debugging only

        //add all objects in section to list ...
        for cnt := 0 to cnt - 1 do
        begin
          new(PdfObj);
          PdfObjList.Add(PdfObj);
          PdfObj.number := k + cnt;
          if not GetNumber(PdfObj.offset) then exit;
          PdfObj.filePtr := pchar(ms.Memory) + PdfObj.offset;
          //14-Apr-07: workaround ... while each entry SHOULD be
          //exactly 20 bytes, not everyone seems to adhere to this.
          while not (p^ in [#10, #13]) do inc(p);
          while (p^ in [#10, #13]) do inc(p);

          //debugging only ...
          //if p <> p2 + 20 then halt; p2 := p;
        end;
        //check for and process further subsections ...