vpdfdoc.pas

生成PDF文档的控件

  TTIFFPaintType);
var
  ImIndex: Integer;
  TiffImage: PTIFF;
  ImPageWidth, ImPageHeight: Cardinal;
  PageBitmap: TBitmap;

  procedure ShowTiffImage;
  var
    SCLineStr: PCardn;
    ImBuff: PCardn;
    ScanLen: Cardinal;
    NewBMLength: Cardinal;
    ImCont, ImRow, ImPos: Cardinal;
    PLConfig, ImageLength: Cardinal;
  const
    PrintTempHeight = 1200;
  begin
{$IFNDEF VOLDVERSION}
    TIFFGetField(TiffImage, TIFFTAG_IMAGEWIDTH, @ImPageWidth);
    TIFFGetField(TiffImage, TIFFTAG_IMAGELENGTH, @ImPageHeight);
{$ELSE}
    TIFFGetField(TiffImage, TIFFTAG_IMAGEWIDTH, ImPageWidth);
    TIFFGetField(TiffImage, TIFFTAG_IMAGELENGTH, ImPageHeight);
{$ENDIF}
    if PaintType = tptResizePage then
    begin
      CurrentPage.Width := ImPageWidth;
      CurrentPage.Height := ImPageHeight;
    end;
    PageBitmap.Width := ImPageWidth;
    if ImPageHeight < PrintTempHeight then
    begin
      PageBitmap.Height := ImPageHeight;
      TIFFReadRGBAImage(TiffImage, ImPageWidth, ImPageHeight, PageBitmap.Scanline[ImPageHeight - 1], 0);
      TIFFReadRGBAImageSwapRB(ImPageWidth, ImPageHeight, PageBitmap.Scanline[ImPageHeight - 1]);
      if (Compression > icJpeg) then
      begin
        PageBitmap.PixelFormat := pf4bit;
        PageBitmap.Monochrome := true;
        PageBitmap.PixelFormat := pf1bit;
      end
      else
        PageBitmap.PixelFormat := pf24bit;
      ImIndex := AddImageFromTIFF(PageBitmap, Compression);
      CurrentPage.ShowImage(ImIndex, 0, 0, CurrentPage.Width, CurrentPage.Height, 0);
    end
    else
    begin
      ImRow := 0;
      ImCont := 0;
{$IFNDEF VOLDVERSION}
      TIFFGetField(TiffImage, TIFFTAG_IMAGELENGTH, @ImageLength);
      TIFFGetField(TiffImage, TIFFTAG_PLANARCONFIG, @PLConfig);
{$ELSE}
      TIFFGetField(TiffImage, TIFFTAG_IMAGELENGTH, ImageLength);
      TIFFGetField(TiffImage, TIFFTAG_PLANARCONFIG, PLConfig);
{$ENDIF}
      ImBuff := (PCardn(_TIFFmalloc(ImPageWidth * ImPageHeight * sizeof(Cardinal))));
      try
        TIFFReadRGBAImage(TiffImage, ImPageWidth, ImPageHeight, ImBuff, 0);
        while (ImCont < (ImageLength - 1)) do
        begin
          if ((ImCont + PrintTempHeight) < ImageLength - 1) then NewBMLength := PrintTempHeight
          else NewBMLength := (ImageLength - ImCont);
          PageBitmap.PixelFormat := pf32bit;
          PageBitmap.Height := NewBMLength;
          ImPos := ImCont;
          while ((ImPos - ImCont) < NewBMLength) do
          begin
            ScanLen := (ImPageWidth * (ImPageHeight - (ImPos + 1)));
            SCLineStr := ImBuff;
            Inc(SCLineStr, ScanLen);
            MoveMemory(PageBitmap.Scanline[ImPos - ImCont], SCLineStr, ImPageWidth * sizeof(Cardinal));
            Inc(ImPos);
          end;
          if (Compression > icJpeg) then
          begin
            PageBitmap.PixelFormat := pf4bit;
            PageBitmap.Monochrome := true;
            PageBitmap.PixelFormat := pf1bit;
          end
          else
            PageBitmap.PixelFormat := pf24bit;
          ImIndex := AddImageFromTIFF(PageBitmap, Compression);
          if PaintType = tptResizePage then
          begin
            CurrentPage.ShowImage(ImIndex, 0, ImRow, ImPageWidth, NewBMLength, 0);
            ImRow := ImRow + (NewBMLength - 1);
          end
          else
          begin
            CurrentPage.ShowImage(ImIndex, 0, ImRow, CurrentPage.Width, NewBMLength * (CurrentPage.Width / ImPageWidth), 0);
            ImRow := ImRow + trunc((NewBMLength * (CurrentPage.Width / ImPageWidth)) - 1);
          end;
          ImCont := ImCont + (NewBMLength - 1);
        end;
      finally
        _TIFFfree(ImBuff);
      end;
    end;
  end;

begin
  TiffImage := TIFFOpen(AnsiString(FileName), 'r');
  try
    if (TiffImage = nil) then raise exception.Create('Invalid tiff file name');
    PageBitmap := TBitmap.Create;
    try
      PageBitmap.PixelFormat := pf32bit;
      ShowTiffImage;
      while (TIFFReadDirectory(TiffImage) > 0) do
      begin
        AddPage;
        PageBitmap.PixelFormat := pf32bit;
        ShowTiffImage;
      end;
    finally
      PageBitmap.Free;
    end;
  finally
    TIFFClose(TiffImage);
  end;
end;

procedure TVPDF.SetDocImagearray(Width, Height: Integer);
begin
  SetLength(FSizes, FCurrentImageIndex + 1);
  FSizes[FCurrentImageIndex].width := Width;
  FSizes[FCurrentImageIndex].heigh := Height;
end;

procedure TVPDF.SetResolution(const Value: Integer);
begin
  DocScale := Value / 72;
  FResolution := Value;
end;

procedure TVPDF.SetViewerPreferences(const Value: TVPDFViewerPreferences);
begin
  FVPChanged := true;
  FViewerPreference := Value;
end;

function TVPDF.AddImageFromTIFF(Image: TBitmap; Compression: TVPDFImageCompressionType): Integer;
begin
  result := MapImage(image, Compression, false, -1);
end;

function TVPDF.LoadDocHeader: AnsiString;
begin
  FInStream.Position := 0;
  result := LoadDocString;
end;

procedure TVPDF.PadTrunc(S: Pointer; SL: Integer; D: Pointer);
var
  I, J: Integer;
begin
  I := 0;
  while ((I < 32) and (I < SL)) do
  begin
    PByteArray(D)[I] := PByteArray(S)[I];
    Inc(I);
  end;
  J := 1;
  while (I < 32) do
  begin
    PByteArray(D)[I] := PadStr[J];
    Inc(I);
    Inc(J);
  end;
end;

procedure TVPDF.CreateKeys;
var
  RCData, RTCData: TRC4Data;
  ID1Supl, ID2Supl, ID3Supl: AnsiString;
  CryptoStr: AnsiString;
  CryptContext: MD5Context;
  TmpDigest, Digest: MD5Digest;
  TmpKeyLength: Integer;
  Pass: array[0..31] of byte;
  I, H, ol, ul: Integer;
begin
  ol := 0;
  ul := 0;
  if (FOwnerPassword <> '') then
    ol := Length(FOwnerPassword);
  if (FUserPassword <> '') then
    ul := Length(FUserPassword);
  if (ol = 0) then
    PadTrunc(@FUserPassword[1], ul, @Pass[0])
  else
    PadTrunc(@FOwnerPassword[1], ol, @Pass[0]);
  Digest := MD5String(@Pass[0], 32);
  if (FRevision = 3) then
  begin
    for I := 1 to 50 do
      Digest := MD5String(@Digest, 16);
    TmpKeyLength := 16;
  end
  else
  begin
    TmpKeyLength := 5;
  end;
  RC4Init(RCData, @Digest, TmpKeyLength);
  PadTrunc(@FUserPassword[1], ul, @Pass[0]);
  SetLength(OwUsPass, 32);
  RC4Crypt(RCData, @Pass[0], @OwUsPass[1], 32);
  if (FRevision = 3) then
    for I := 1 to 19 do
    begin
      for H := 0 to 15 do
        TmpDigest[H] := Digest[H] xor I;
      RC4Init(RCData, @TmpDigest, TmpKeyLength);
      RC4Crypt(RCData, @OwUsPass[1], @OwUsPass[1], 32);
    end;
  ID2Supl := OwUsPass;
  SetLength(ID1Supl, 32);
  PadTrunc(@FUserPassword[1], ul, @ID1Supl[1]);
  MD5Init(CryptContext);
  MD5Update(CryptContext, @ID1Supl[1], 32);
  MD5Update(CryptContext, @ID2Supl[1], 32);
  MD5Update(CryptContext, PAnsiChar(@ProtectFlags), 4);
  ID3Supl := '';
  for i := 1 to 16 do
    ID3Supl := ID3Supl + AnsiChar(chr(StrToInt('$' + String(DocID[i shl 1 - 1]) + String(DocID[i shl 1]))));
  MD5Update(CryptContext, @ID3Supl[1], 16);
  MD5Final(CryptContext, Digest);
  if (FRevision = 3) then
  begin
    for i := 1 to 50 do
    begin
      Digest := MD5String(@Digest, 16);
    end;
  end;
  Move(Digest, FCurrentKey, TmpKeyLength);
  if (FRevision = 2) then
  begin
    RC4Init(RTCData, @FCurrentKey, 5);
    RC4Crypt(RTCData, @PadStr, @Pass, 32);
    UsPassStr := '';
    for I := 1 to 32 do
      UsPassStr := UsPassStr + AnsiChar(chr(Pass[I - 1]));
  end
  else
  begin
    MD5Init(CryptContext);
    MD5Update(CryptContext, @PadStr, 32);
    CryptoStr := '';
    for i := 1 to 16 do
      CryptoStr := CryptoStr + AnsiChar(chr(StrToInt('$' + String(DocID[i shl 1 - 1]) + String(DocID[i shl 1]))));
    MD5Update(CryptContext, @CryptoStr[1], 16);
    MD5Final(CryptContext, Digest);
    RC4Init(RTCData, @FCurrentKey[0], 16);
    RC4Crypt(RTCData, @Digest, @Digest, 16);
    for I := 1 to 19 do
    begin
      for H := 0 to 15 do
        TmpDigest[H] := FCurrentKey[H] xor i;
      RC4Init(RTCData, @TmpDigest, 16);
      RC4Crypt(RTCData, @Digest, @Digest, 16);
    end;
    SetLength(UsPassStr, 32);
    Move(Digest, UsPassStr[1], 16);
    for I := 17 to 32 do
      UsPassStr[i] := ' ';
  end;
end;

procedure TVPDF.EnableEncrypt;
var
  CFObj: TVPDFDictionaryObject;
  StdCFObj: TVPDFDictionaryObject;
  EncryptObj: TVPDFDictionaryObject;
begin
  EncryptObj := CreateIndirectDictionary;
  FEncryprtIndex := FMaxObjNum - 1;
  EncryptObj.AddNameValue('Filter', 'Standard');
  if FCryptKeyType = k40 then
  begin
    ProtectFlags := -64;
    EncryptObj.AddNumericValue('V', 1);
    EncryptObj.AddNumericValue('R', 2);
    if prPrint in FProtectOption then
      ProtectFlags := ProtectFlags or 4;
    if prModifyStructure in FProtectOption then
      ProtectFlags := ProtectFlags or 8;
    if prInformationCopy in FProtectOption then
      ProtectFlags := ProtectFlags or 16;
    if prEditAnnotations in FProtectOption then
      ProtectFlags := ProtectFlags or 32;
  end
  else
  begin
    ProtectFlags := -3904;
    if FCryptKeyType = k128 then
    begin
      EncryptObj.AddNumericValue('V', 2);
      EncryptObj.AddNumericValue('R', 3);
    end
    else
    begin
      EncryptObj.AddNameValue('StmF', 'StdCF');
      EncryptObj.AddNumericValue('V', 4);
      EncryptObj.AddNumericValue('R', 4);
      StdCFObj := TVPDFDictionaryObject.Create(nil);
      StdCFObj.AddNumericValue('Length', 16);
      StdCFObj.AddNameValue('CFM', 'AESV2');
      StdCFObj.AddNameValue('AuthEvent', 'DocOpen');
      CFObj := TVPDFDictionaryObject.Create(nil);
      CFObj.AddValue('StdCF', StdCFObj);
      EncryptObj.AddValue('CF', CFObj);
      EncryptObj.AddNameValue('StrF', 'StdCF');
    end;
    EncryptObj.AddNumericValue('Length', 128);
    if prPrint in FProtectOption then
      ProtectFlags := ProtectFlags or 4;
    if prModifyStructure in FProtectOption then
      ProtectFlags := ProtectFlags or 8;
    if prInformationCopy in FProtectOption then
      ProtectFlags := ProtectFlags or 16;
    if prEditAnnotations in FProtectOption then
      ProtectFlags := ProtectFlags or 32;
    if prFillAnnotations in FProtectOption then
      ProtectFlags := ProtectFlags or 256;
    if prExtractContent in FProtectOption then
      ProtectFlags := ProtectFlags or 512;
    if prAssemble in FProtectOption then
      ProtectFlags := ProtectFlags or 1024;
    if prPrint12bit in FProtectOption then
      ProtectFlags := ProtectFlags or 2048;
  end;
  CreateKeys;
  EncryptObj.AddNumericValue('P', ProtectFlags);
  EncryptObj.AddStringValue('O', OwUsPass);
  EncryptObj.AddStringValue('U', UsPassStr);
end;

function TVPDF.CrptStr(Data: AnsiString; Password: MD5Digest; PassLength:
  TVPDFKeyType; ObjID: Integer): AnsiString;
var
  I: Integer;
  RC4Len, MD5Len: Integer;
  CrStr: AnsiString;
  RCKey: TRC4Data;
  Digest: MD5Digest;
  CCover: TVPDFContCover;
  FCRLen: Integer;
  CryptKey: array[0..20] of Byte;
  VECT: array[0..15] of Byte;
  EncData: AnsiString;
begin
  if Data = '' then
  begin
    Result := Data;
    Exit;