vpdfdoc.pas

生成PDF文档的控件

  end;
  CrStr := Data;
  FillChar(CryptKey, 21, 0);
  if PassLength = k40 then
  begin
    Move(Password, CryptKey, 5);
    Move(ObjID, CryptKey[5], 3);
    MD5Len := 10;
    RC4Len := 10;
  end
  else
  begin
    Move(Password, CryptKey, 16);
    Move(ObjID, CryptKey[16], 3);
    MD5Len := 21;
    RC4Len := 16;
  end;
  Digest := MD5String(@CryptKey[0], MD5Len);
  if PassLength = aes128 then
  begin
    exit;
    CCover := TVPDFContCover.Create;
    try
      FCRLen := (Length(Data) div 16) * 16;
      CCover.InitAlg(@Digest[0], 16);
      for I := 0 to 15 do
      begin
        VECT[I] := Byte(Random(220) + 33);
      end;
      EncData := '';
      for I := 0 to FCRLen - 1 do
      begin
        EncData := EncData + ' ';
      end;
      // CCover.DelimitAlg(@DataBlock[0], FCRLen, @EncData[1], @VECT[0]);
    finally
      CCover.Free;
    end;
    CrStr := '';
    for I := 0 to 15 do
    begin
      CrStr := CrStr + AnsiChar(CHR(VECT[I]));
    end;
    Result := CrStr + EncData;
  end
  else
  begin
    RC4Init(RCKey, @Digest, RC4Len);
    RC4Crypt(RCKey, @CrStr[1], @CrStr[1], Length(CrStr));
    Result := CrStr;
  end;
end;

procedure TVPDF.CrptStrm(Data: TMemoryStream; Password: MD5Digest;
  PassLength: TVPDFKeyType; ObjID: Integer);
var
  RCKey: TRC4Data;
  CryptKey: array[0..20] of Byte;
  Digest: MD5Digest;
  RC4Len, MD5Len: Integer;
begin
  if Data.Size = 0 then
    Exit;
  FillChar(CryptKey, 21, 0);
  if PassLength = k40 then
  begin
    Move(Password, CryptKey, 5);
    Move(ObjID, CryptKey[5], 3);
    MD5Len := 10;
    RC4Len := 10;
  end
  else
  begin
    Move(Password, CryptKey, 16);
    Move(ObjID, CryptKey[16], 3);
    MD5Len := 21;
    RC4Len := 16;
  end;
  Digest := MD5String(@CryptKey[0], MD5Len);
  RC4Init(RCKey, @Digest, RC4Len);
  RC4Crypt(RCKey, Data.Memory, Data.Memory, Data.Size);
end;

function TVPDF.LoadIsLinearized: boolean;
var
  LinearVal: AnsiString;
  DocStr: AnsiString;
  DocPos: Integer;
  LinearPos: Integer;
begin
  result := false;
  DocPos := FInStream.Position;
  DocStr := LoadDocString;
  while Pos('obj', LowerCase(String(DocStr))) = 0 do
    DocStr := LoadDocString;
  while Pos('endobj', LowerCase(String(DocStr))) = 0 do
  begin
    DocStr := LoadDocString;
    LinearPos := Pos('linearized', LowerCase(String(DocStr)));
    if LinearPos > 0 then
    begin
      LinearPos := LinearPos + 10;
      while DocStr[LinearPos] = ' ' do
        Inc(LinearPos);
      LinearVal := '';
      while (((DocStr[LinearPos] >= '-') and (DocStr[LinearPos] <= '9'))) do
      begin
        LinearVal := LinearVal + DocStr[LinearPos];
        Inc(LinearPos);
      end;
      if (LinearVal = '1') then
        result := true;
      break;
    end;
  end;
  FInStream.Position := DocPos;
end;

procedure TVPDF.LoadXrefArray;
var
  PSkLine: Pointer;
  SkLine: AnsiString;
  DocLine: AnsiString;
  PrevPos: Integer;

  function GetFirstNunmer(NumStr: AnsiString; Index: Integer): AnsiString;
  var
    StrLen: Integer;
    StrIndex: Integer;
  begin
    StrLen := Length(NumStr);
    StrIndex := Index;
    Result := '';
    while (StrIndex <= StrLen) do
    begin
      if ((NumStr[StrIndex] >= '0') and (NumStr[StrIndex] <= '9'))
        then
        Result := Result + NumStr[StrIndex]
      else
        Break;
      Inc(StrIndex);
    end;
  end;

begin
  PrevPos := FInStream.Position;
  SkLine := '                    ';
  PSkLine := @SkLine[1];
  while (Pos('trailer', LowerCase(String(SkLine))) = 0) do
  begin
    PrevPos := FInStream.Position;
    DocLine := LoadDocString;
    while ((Pos('n', String(DocLine)) = 0) and (Pos('trailer', LowerCase(String(DocLine))) = 0)) do
    begin
      PrevPos := FInStream.Position;
      DocLine := LoadDocString;
    end;
    FInStream.Position := PrevPos;
    FInStream.Read(PSkLine^, 20);
    if SkLine[18] = 'n' then
    begin
      Inc(FXrefLen);
      SetLength(FXref, FXrefLen);
      FXref[FXrefLen - 1].Offset := StrToInt(Copy(String(SkLine), 1, 10));
    end;
  end;
  FInStream.Position := PrevPos;
end;

function TVPDF.GetOutlineRoot: TVPDFDocOutlineObject;
begin
  if (FOutlineRoot = nil) then
  begin
    FOutlineRoot := TVPDFDocOutlineObject.Create;
    FOutlineRoot.Init(Self);
  end;
  Result := FOutlineRoot;
end;

function TVPDF.GetObjectNumber: TVPDFObjectNumber;
var
  ObjPos: Integer;
  DelimiterPos: Integer;
  PLineStr: Pointer;
  LineStr: AnsiString;
begin
  ObjPos := FInStream.Position;
  LineStr := '            ';
  PLineStr := @LineStr[1];
  FInStream.Read(PLineStr^, 10);
  LineStr := AnsiString(Trim(String(LineStr)));
  DelimiterPos := Pos(' ', String(LineStr));
  Result.ObjectNumber := StrToInt(Copy(String(LineStr), 1, DelimiterPos - 1));
  LineStr := AnsiString(Trim(Copy(String(LineStr), DelimiterPos + 1, 12 - DelimiterPos)));
  DelimiterPos := Pos(' ', String(LineStr));
  Result.GenerationNumber := StrToInt(Copy(String(LineStr), 1, DelimiterPos - 1));
  FInStream.Position := ObjPos;
end;

function TVPDF.LoadBooleanObject(ObjStream: TStream): TVPDFBooleanObject;
var
  BoolObjPos: Integer;
  DocChar: AnsiChar;
  DocStr: AnsiString;
begin
  Result := TVPDFBooleanObject.Create(nil);
  ObjStream.Read(DocChar, 1);
  while (DocChar < 'A') do
    ObjStream.Read(DocChar, 1);
  DocStr := '';
  BoolObjPos := ObjStream.Position;
  while ((DocChar > #32) and (not (DocChar in EscapeChars))) do
  begin
    DocStr := DocStr + DocChar;
    ObjStream.Read(DocChar, 1);
  end;
  if (LowerCase(String(DocStr)) = 'true') then
  begin
    Result.Value := true;
    ObjStream.Position := BoolObjPos + 3;
  end
  else
  begin
    Result.Value := false;
    ObjStream.Position := BoolObjPos + 4;
  end;
end;

procedure TVPDF.CryptStream(Data: TMemoryStream; ID: Integer);
begin
  if FProtection then
    CrptStrm(Data, FCurrentKey, FCryptKeyType, ID);
end;

function TVPDF.CryptString(Data: AnsiString; ID: Integer): AnsiString;
begin
  if FProtection then
    Result := CrptStr(Data, FCurrentKey, FCryptKeyType, ID)
  else
    Result := Data;
end;

procedure TVPDF.SetOutputStream(const Value: TStream);
begin
  if FDocStarted then
    raise Exception.Create('Cannot set OutputStream value - document in progress.');
  FOutputStream := Value;
  FMemStream := true;
end;

function TVPDF.LoadNumericObject(ObjStream: TStream): TVPDFNumericObject;
var
  WholePart: AnsiString;
  DecLen: Integer;
  DecPart: AnsiString;
  DecPointPos: Integer;
  DecLenPart: Integer;
  DocChar: AnsiChar;
  Decpt: real;
  DocStr: AnsiString;

begin
  Result := TVPDFNumericObject.Create(nil);
  ObjStream.Read(DocChar, 1);
  while (DocChar < '-') do
    ObjStream.Read(DocChar, 1);
  DocStr := '';
  while ((DocChar > #32) and (not (DocChar in EscapeChars))) do
  begin
    DocStr := DocStr + DocChar;
    ObjStream.Read(DocChar, 1);
  end;
  if (DocChar in EscapeChars) then ObjStream.Position := ObjStream.Position - 1;
  DecPointPos := Pos('.', String(DocStr));
  if (DecPointPos <> 0) then
  begin
    WholePart := Copy(DocStr, 1, DecPointPos - 1);
    DecLenPart := Length(DocStr) - DecPointPos;
    if (DecLenPart <= 8) then
      DecPart := Copy(DocStr, DecPointPos + 1, DecLenPart)
    else
      DecPart := Copy(DocStr, DecPointPos + 1, 8);
    DecLen := Length(DecPart);
    Decpt := StrToInt(String(DecPart)) / Power(10, DecLen);
    Result.Value := ABS(StrToInt(String(WholePart))) + Decpt;
    if (DocStr[1] = '-') then Result.Value := -Result.Value;
  end
  else
    Result.Value := StrToInt(String(DocStr));
end;

function TVPDF.MapImage(Image: TGraphic; Compression: TVPDFImageCompressionType;
  IsMask: boolean; MaskIndex: Integer): Integer;
var
  I: Integer;
  XMLen: Integer;
  XOLink: TVPDFLink;
  NewObjName: AnsiString;
  XObject: TVPDFObject;
  CurrVImage: TVPDFImage;
begin
  XOLink := nil;
  XMLen := Length(XImages);
  if MaskIndex > -1 then
  begin
    if MaskIndex > FCurrentImageIndex then
    begin
      raise Exception.Create('Incorrect mask index.');
      Exit;
    end;
    for I := 0 to XMLen - 1 do
    begin
      if (MaskIndex = XImages[i].Index) then
      begin
        XObject := XImages[i].ImageObject;
        XOLink := TVPDFLink.Create;
        XOLink.Value.ObjectNumber := XObject.ID.ObjectNumber;
        XOLink.Value.GenerationNumber := XObject.ID.GenerationNumber;
        Break;
      end;
    end;
  end;
  SetDocImagearray(Image.Width, Image.Height);
  if not ((Image is TJPEGImage) or (Image is TBitmap)) then
    raise Exception.Create('Unsupported image format.');
  NewObjName := 'Im' + AnsiString(IntToStr(FCurrentImageIndex));
  while (FCurrentPage.CompareResName(0, NewObjName) > -1) do
  begin
    Inc(FCurrentImageIndex);
    NewObjName := 'Im' + AnsiString(IntToStr(FCurrentImageIndex));
  end;
  case Compression of
    icJpeg: begin
        CurrVImage := TVPDFImage.Create(Image, 0, IsMask, XOLink, NewObjName, FJpegQuality);
      end;
    icCCITT31: begin
        CurrVImage := TVPDFImage.Create(Image, 2, IsMask, XOLink, NewObjName, FJpegQuality);
      end;
    icCCITT32: begin
        CurrVImage := TVPDFImage.Create(Image, 3, IsMask, XOLink, NewObjName, FJpegQuality);
      end;
    icCCITT42: begin
        CurrVImage := TVPDFImage.Create(Image, 4, IsMask, XOLink, NewObjName, FJpegQuality);
      end;
  else
    begin
      CurrVImage := TVPDFImage.Create(Image, 1, IsMask, XOLink, NewObjName, FJpegQuality);
    end;
  end;
  Inc(FMaxObjNum);
  CurrVImage.IsIndirect := true;
  CurrVImage.ID.ObjectNumber := FMaxObjNum;
  Inc(XMLen);
  SetLength(XImages, XMLen);
  XImages[XMLen - 1].Index := FCurrentImageIndex;
  XImages[XMLen - 1].Name := NewObjName;
  XImages[XMLen - 1].ImageObject := CurrVImage;
  XImages[XMLen - 1].Width := Image.W