usealpdf.pas

给PDF文件加盖印章或背景

        if p^ in ['0'..'9'] then continue;

        // parse 'trailer dictionary' ...
        if not IsString('trailer') then exit;
        p2 := p;
        // get Root (aka Catalog) ...
        if (rootNum = -1) and FindStrInDict('/Root') then
          if not GetNumber(rootNum) then exit;
        p := p2;
        if not FindStrInDict('/Prev') then break; //no more xrefs

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

      end; //bottom of loop /////////////////////////////////////

      //Make sure we've got Root the object number ...
      if rootNum < 0 then exit;
      //Find Root object in list and go to its offset ...
      k := 0;
      while k < PdfObjList.Count do
        if PPdfObj(PdfObjList[k]).number = rootNum then
          break else
          inc(k);
      if k = PdfObjList.Count then exit;
      p := PPdfObj(PdfObjList[k]).filePtr;

      //get the object number and make sure that it is the Root object ...
      if not GetNumber(k) or (k <> rootNum) then exit;

      if not FindStrInDict('/Pages') then exit;
      //get Pages object number ==> pagesNum
      if not GetNumber(pagesNum) then exit;
      k := 0;
      while k < PdfObjList.Count do
        if PPdfObj(PdfObjList[k]).number = pagesNum then
          break else
          inc(k);
      if k = PdfObjList.Count then exit;
      //Pages object found in list, now go to offset ...
      p := pchar(ms.Memory) + PPdfObj(PdfObjList[k]).offset;
      //make sure it's the Pages object ...
      if not GetNumber(k) or (k <> pagesNum) then exit;
      if not FindStrInDict('/Count') then exit;
      if not GetNumber(cnt) then exit;
      //21-Jun-05: bugfix
      //occasionally the 'count' value is an indirect object
      if GetNumber(k) and IsString(' R') then
      begin
        //this is an indirect object to the count value,
        //so find the obj ...
        k := 0;
        while k < PdfObjList.Count do
          if PPdfObj(PdfObjList[k]).number = cnt then
            break else
            inc(k);
        if k = PdfObjList.Count then exit;
        p := pchar(ms.Memory) + PPdfObj(PdfObjList[k]).offset;
        if not GetNumber(k) or //skip the object num
          not GetNumber(k) or //skip the generation num
          not IsString(' obj') or
          not GetNumber(cnt) then exit;
      end;
      result := cnt;
    finally
      for k := 0 to PdfObjList.Count - 1 do
        dispose(PPdfObj(PdfObjList[k]));
      PdfObjList.Free;
      ms.Free;
    end;
  except
    //nb: errors are flagged by returning -1
  end;
end;
function TPdfSeal.CreateTempPDF(P1, P2, P3, P4, P5, P6: string; var TempFile: string; iPos: integer = 2): boolean;
var
  FDoc: TPdfDoc;
  FOutFile: TFileStream;
  function StrIsWide(S: string): boolean;
  var //判断该S字符是否为双字节--汉字;
    SD: WideString;
  begin
    SD := S;
    Result := length(SD) <> length(S);
  end;
  function GetStringLength(S: string): Single; //字符实际长度;
  var
    i: integer;
    vW, W1: Single;
    vS: wideString;
  begin
    vS := S;
    W1 := 0;
    with FDoc.Canvas do
    begin
      for i := 1 to length(vS) do
      begin
        if StrIsWide(vS[i]) then
          SetFont('Chinese', 10.5) //汉字用字体设置;
        else
          SetFont('Arial', 10.5);
        MeasureText(vS[i], 130, vW); //vW 字符实际长度，k字符实际字数;
        W1 := W1 + vW;
      end
    end;
    Result := W1;
  end;
  procedure DrawLine(X1, Y1, X2, Y2, Width: Single);
  begin
    with FDoc.Canvas do
    begin
      MoveTo(X1, Y1);
      LineTo(X2, Y2);
      Stroke;
    end;
  end;
  procedure WriteRow(XPos, YPos: Single; S: string);
  var
    i: integer;
    vXPos, vW: Single;
    vS: wideString;
  begin
    vS := S;
    vW := 0;
    vXPos := XPos;
//    FDoc.Canvas.SetRGBFillColor();
    with FDoc.Canvas do
    begin
      for i := 1 to length(vS) do
      begin
        if StrIsWide(vS[i]) then
          SetFont('Chinese', 10.5) //汉字用字体设置;
        else
          SetFont('Arial', 10.5);
        SetRGBFillColor($000000FF);
        MeasureText(vS[i], 130, vW); //vW 字符实际长度，k字符实际字数;
        TextOut(vXPos, YPos, vS[i]);
        vXPos := vXPos + vW;
      end
    end;
  end;
  procedure WritePage(P1, P2, P3, P4, P5, P6: string; iPos: integer = 2);
  var
    XPos, YPos: Single;
    WPos, HPos: single;
    sLeng: Single;
    PgW, PgH: integer;
  begin
  //iPos 印章位置 1,左上，2，右上，3左下，4右下,5居中
    PgW := FDoc.Canvas.PageWidth;
    PgH := FDoc.Canvas.PageHeight;
    WPos := 150;
    HPos := 60;
    case iPos of
      1: begin
          XPos := 10;
          YPos := PgH - HPos - 30;
        end;
      3: begin
          XPos := 10;
          YPos := 30;
        end;
      4: begin
          XPos := PgW - WPos - 10;
          YPos := 30;
        end;
      5: begin
          XPos := (PgW - WPos) / 2;
          YPos := (PgH - HPos) / 2;
        end;
    else begin
        XPos := PgW - WPos - 10;
        YPos := PgH - HPos - 30;
      end;
    end;

    with FDoc.Canvas do
    begin
      SetRGBStrokeColor($000000FF);
      SetLineWidth(1.5);
      Rectangle(XPos, YPos, WPos, HPos); //画印章外框;
      Stroke;
      SetLineWidth(0.8);
      DrawLine(XPos, YPos + HPos / 2, WPos + XPos, YPos + HPos / 2, 1);
      DrawLine(XPos + WPos / 3, YPos, XPos + WPos / 3, YPos + HPos, 1);
      DrawLine(XPos + 2 * WPos / 3, YPos, XPos + 2 * WPos / 3, YPos + HPos, 1);
    // if StrIsWide()
    end;
  ////////前三列数据
    sLeng := GetStringLength(p1); //得到字符实际长度以便设置到中间;
    WriteRow(XPos + (WPos / 3 - sLeng) / 2, YPos + (HPos / 2 + HPos / 6), P1);
    sLeng := GetStringLength(p2);
    WriteRow(XPos + WPos / 3 + (WPos / 3 - sLeng) / 2, YPos + (HPos / 2 + HPos / 6), P2);
    sLeng := GetStringLength(p3);
    WriteRow(XPos + 2 * WPos / 3 + (WPos / 3 - sLeng) / 2, YPos + (HPos / 2 + HPos / 6), P3);
  ////////后三列数据
    sLeng := GetStringLength(p4); //得到字符实际长度以便设置到中间;
    WriteRow(XPos + (WPos / 3 - sLeng) / 2, YPos + HPos / 6, P4);
    sLeng := GetStringLength(p5);
    WriteRow(XPos + WPos / 3 + (WPos / 3 - sLeng) / 2, YPos + HPos / 6, P5);
    sLeng := GetStringLength(p6);
    WriteRow(XPos + 2 * WPos / 3 + (WPos / 3 - sLeng) / 2, YPos + HPos / 6, P6);
  end;
begin
  if not DirectoryExists(tmpPath) then
    if not CreateDir(tmpPath) then
    begin
      Result := false;
      exit;
    end;
  TempFile := tmpPath + ChangeFileExt(MakeGUID, '.pdf');
  try
    FOutFile := TFileStream.Create(TempFile, fmCreate);
    FDoc := TPdfDoc.Create;
    with FDoc do
    begin
      try
        NewDoc;
        AddPage;
        WritePage(P1, P2, P3, P4, P5, P6, iPos); //画印章;
        FDoc.SaveToStream(FOutFile);
      finally
        FDoc.Free;
      end;
    end;
  except
    Result := false;
    exit;
  end;
  FOutFile.Free;
  Result := fileExists(TempFile);
end;

function TPdfSeal.DoSealOk(PdfFileName,NewPDF:string): boolean;
var
  ErrorNum: DWORD;
  s, TempF: string;
  ErrorMessage: string;
  succeeded: boolean;
  SrcFilePDF, ArcFilePDF, DfName: string;
  function ExecuteCommand(const command: string): boolean;
  var
    resultStr: string;
  begin
    //application.ProcessMessages;
    try
      ErrorNum := WinExecAndWait32(command, SW_HIDE, 0, resultStr);
      result := ErrorNum = 0;
      if not result then ErrorMessage := resultStr;
    finally

    end;
  end;
begin
  Result := false;
  ErrorMessage := '';
  ErrorNum := 0;
  if not ForceDirectories(tmpPath) then exit;
  if not ExtractRes('EXEFILE','pdftk',pdfTkpath+'pdftk.exe') then exit;
  try
    if not CreateTempPDF(sParam1, sParam2, sParam3, sParam4, sParam5, sParam6, TempF, iPosition) then exit; //创建模版文件;
    if not FileExists(pdfTkpath + 'pdftk.exe') then
    begin
      exit;
    end;
    if not fileExists(PdfFileName)  then exit;
    DFName := ChangeFileExt(NewPDF, '.pdf');
    if PdfFileName = NewPDF then
    begin
      beep;
      exit;
    end;
      //SrcFilePDF := EdtFile.Text;
    SrcFilePDF := tmpPath + ChangeFileExt(MakeGUID, '.pdf');
    if not CopyFile(PChar(PdfFileName), Pchar(SrcFilePDF), True) then exit;
    ArcFilePDF := tmpPath + ChangeFileExt(MakeGUID, '.pdf');
    if (GetPdfPageCount(SrcFilePDF) > 1) then //只在第一页增加; cbPageOneOnly.Checked and
    begin
        //split off page 1 to tmp1.pdf ...
      s := format('"%spdftk.exe" A="%s" cat A1 output "%stmp1.pdf" %s %s %s dont_ask',
        [pdfTkpath, SrcFilePDF, tmpPath,
        allowParams, ownerParam, userParam]);
      succeeded := executeCommand(s);
        //create tmp3.pdf from backgrounded page 1 ...
      if succeeded then
      begin
        s := format('%spdftk.exe A="%stmp1.pdf" %s "%s" output "%stmp3.pdf" %s %s %s dont_ask',
          [PdfTkPath, tmpPath, action, TempF,
          tmpPath, allowParams, ownerParam, userParam]);
        succeeded := executeCommand(s);
      end
      else exit;
        //split off page 2 to end to tmp2.pdf ...
      if succeeded then
      begin
        s := format('"%spdftk.exe" A="%s" cat A2-end output "%stmp2.pdf" %s %s %s dont_ask',
          [PdfTkPath, SrcFilePDF, tmpPath,
          allowParams, ownerParam, userParam]);
        succeeded := executeCommand(s);
      end
      else exit;
      if succeeded then
      begin
        //join the result back into one pdf document ...
        s := format('"%spdftk.exe" A="%stmp3.pdf" B="%stmp2.pdf" cat A B output "%s" %s %s %s dont_ask',
          [PdfTkPath, tmpPath, tmpPath, ArcFilePDF, allowParams, ownerParam, userParam]);
        succeeded := executeCommand(s);
      end
      else exit;
    end else
    begin
      succeeded := executeCommand(format('%spdftk.exe A="%s" %s "%s" output "%s" %s %s %s dont_ask',
        [PdfTkPath, SrcFilePDF, action, TempF,
        ArcFilePDF, allowParams, ownerParam, userParam]));
    end;
    CopyFile(PChar(ArcFilePDF), Pchar(DFName), True); //拷贝到新地方;
    if not succeeded then
    begin
       Result:=false;
       exit;
    end;
  finally
    DeleteAllTmpPdfFiles;
  end;
  Result := True;
end;

constructor TPdfSeal.Create;
begin
  inherited;
  tmpPath := GetTempDirectory + 'tmp\';
  PdfTkPath:=tmpPath;
end;

destructor TPdfSeal.Destroy;
begin
  DeleteAllTmpPdfFiles;
  RemoveDir(tmpPath);
  inherited;
end;

end.