vpdfccitt.pas

生成PDF文档的控件

    b1 := finddiff(rp, b1, bits, PIXEL(bp, a0));
  until False;
end;

procedure TVCCITTCompression.Execute(B: TBitmap);
var
  P, L, M: PByte;
  i, j: Integer;
begin
  if FStream = nil then
    raise Exception.Create('Output stream is empty.');
  if B.PixelFormat <> pf1bit then
    raise Exception.Create('Incorrect image format.');
  if (B.Width = 0) or (B.Height = 0) then Exit;
  RowPixels := B.Width;
  RowBytes := (B.Width + 7) shr 3;
  GetMem(P, RowBytes);
  try
    if FCT <> ccitt31d then
      GetMem(Refline, RowBytes)
    else
      Refline := nil;
    try
      Bit := 8;
      Data := 0;
      Tag := G3_1D;
      if Refline <> nil then
        FillChar(Refline^, RowBytes, 0);
      if is2DEncoding then
      begin
        k := 2;
        maxk := 2;
      end
      else
      begin
        k := 0;
        maxk := 0;
      end;
      for i := 0 to B.Height - 1 do
      begin
        L := P;
        M := B.ScanLine[i];
        for j := 0 to RowBytes - 1 do
        begin
          L^ := not M^;
          Inc(L);
          Inc(M);
        end;
        case FCT of
          CCITT42D:
            begin
              if not Encode2DRow(P, Refline, RowPixels) then
                raise Exception.Create('CCITT compression error');
              Move(P^, refline^, RowBytes);
            end;
          CCITT31D:
            begin
              if not Encode1DRow(P, RowPixels) then
                raise Exception.Create('CCITT compression error');
            end;
          CCITT32D:
            begin
              PutBits(1, 12);
              PutBits(0, 1);
              if not Encode2DRow(P, Refline, RowPixels) then
                raise Exception.Create('CCITT compression error');
              Move(P^, refline^, RowBytes);
            end;
        end;
      end;
      if FCT = CCITT42D then
      begin
        PutBits(EOL, 12);
        PutBits(EOL, 12);
      end;
      if bit <> 8 then FlushBits;
    finally
      if Refline <> nil then FreeMem(Refline);
    end;
  finally
    FreeMem(P);
  end;
end;

function TVCCITTCompression.Find0Span(BP: PByte; BS, BE: Integer): Integer;
var
  Bits: Integer;
  Span, N: Integer;
begin
  Bits := BE - BS;
  Inc(BP, bs shr 3);
  n := (bs and 7);
  if (bits > 0) and (Boolean(N)) then
  begin
    span := zeroruns[(bp^ shl n) and $FF];
    if (span > 8 - n) then span := 8 - n;
    if (span > bits) then span := bits;
    if (n + span < 8) then
    begin
      Result := span;
      Exit;
    end;
    Dec(Bits, Span);
    Inc(BP);
  end
  else
    span := 0;
  while bits >= 8 do
  begin
    if BP^ <> 0 then
    begin
      Result := span + zeroruns[bp^];
      Exit;
    end;
    Inc(Span, 8);
    Dec(Bits, 8);
    Inc(BP);
  end;
  if bits > 0 then
  begin
    n := zeroruns[bp^];
    if N > Bits then
      Inc(Span, Bits)
    else
      Inc(Span, N);
  end;
  Result := span;
end;

function TVCCITTCompression.Find1Span(BP: PByte; BS, BE: Integer): Integer;
var
  Bits: Integer;
  Span, N: Integer;
begin
  Bits := BE - BS;
  Inc(BP, bs shr 3);
  n := (bs and 7);
  if (bits > 0) and (Boolean(N)) then
  begin
    span := oneruns[(bp^ shl n) and $FF];
    if (span > 8 - n) then span := 8 - n;
    if (span > bits) then span := bits;
    if (n + span < 8) then
    begin
      Result := span;
      Exit;
    end;
    Dec(Bits, Span);
    Inc(BP);
  end
  else
    span := 0;
  while bits >= 8 do
  begin
    if BP^ <> $FF then
    begin
      Result := span + oneruns[bp^];
      Exit;
    end;
    Inc(Span, 8);
    Dec(Bits, 8);
    Inc(BP);
  end;
  if bits > 0 then
  begin
    n := oneruns[bp^];
    if N > Bits then
      Inc(Span, Bits)
    else
      Inc(Span, N);
  end;
  Result := span;
end;

function TVCCITTCompression.FindDiff(BP: PByte; BS, BE: Integer;
  Color: Integer): Integer;
begin
  if Color = 0 then
    Result := BS + Find0Span(BP, BS, BE)
  else
    Result := BS + Find1Span(BP, BS, BE);
end;

function TVCCITTCompression.FindDiff2(BP: PByte; BS, BE: Integer;
  Color: Integer): Integer;
begin
  if BS < BE then
    Result := Finddiff(BP, BS, BE, Color)
  else
    Result := BE;
end;

procedure TVCCITTCompression.FlushBits;
begin
  FStream.Write(Data, 1);
  Data := 0;
  Bit := 8;
end;

function TVCCITTCompression.is2DEncoding: Boolean;
begin
  Result := (FCT = CCITT32D) or (FCT = CCITT42D);
end;

procedure TVCCITTCompression.PutBits(Bits, Length: Byte);
begin
  while Length > Bit do
  begin
    Data := Data or (Bits shr (Length - Bit));
    Length := Length - Bit;
    FlushBits;
  end;
  Data := Data or ((Bits and msbmask[Length]) shl (Bit - Length));
  Dec(Bit, Length);
  if Bit = 0 then FlushBits;
end;

procedure TVCCITTCompression.PutSpan(Span: Integer; C: Codes);
var
  Code, Length: Byte;
begin
  while span >= 2624 do
  begin
    Code := C[63 + (2560 shr 6)].Code;
    Length := C[63 + (2560 shr 6)].Length;
    PutBits(Code, Length);
    Dec(Span, C[63 + (2560 shr 6)].RunLen);
  end;
  if Span >= 64 then
  begin
    Code := C[63 + (Span shr 6)].Code;
    Length := C[63 + (Span shr 6)].Length;
    PutBits(Code, Length);
    Dec(Span, C[63 + (Span shr 6)].RunLen);
  end;
  Code := C[Span].Code;
  Length := C[Span].Length;
  PutBits(Code, Length);
end;

procedure TVCCITTCompression.CompressImage(AImage: TGraphic; CompressType: Integer; SaStream: TStream);
var
  ABitmap: TBitmap;

begin
  ABitmap := TBitmap.Create;
  try
    ABitmap.Assign(AImage);
    if not (ABitmap.PixelFormat = pf1bit) then raise Exception.Create('Image format must be B/W.');
    case CompressType of
      31: CompressionType := CCITT31D;
      32: CompressionType := CCITT32D;
      42: CompressionType := CCITT42D;
    end;
    Self.Stream := SaStream;
    Self.Execute(ABitmap);
  finally
    ABitmap.Free;
  end;
end;

end.