vpdftiff.pas

生成PDF文档的控件

function TIFFcallvjpeg_jpeg_write_tables(cinfo: PRJpegCompressStruct): Integer; cdecl;
begin
  try
    jpeg_write_tables(cinfo);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcalljpeg_jpeg_read_header(errreturn: Integer; cinfo: PRJpegDecompressStruct; require_image: Byte): Integer;
  cdecl;
begin
  try
    Result := jpeg_read_header(cinfo, Boolean(require_image));
  except
    Result := errreturn;
  end;
end;

function TIFFcallvjpeg_jpeg_start_decompress(cinfo: PRJpegDecompressStruct): Integer; cdecl;
begin
  try
    jpeg_start_decompress(cinfo);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcalljpeg_jpeg_read_scanlines(errreturn: Integer; cinfo: PRJpegDecompressStruct; scanlines: Pointer;
  max_lines: Cardinal): Integer; cdecl;
begin
  try
    Result := jpeg_read_scanlines(cinfo, scanlines, max_lines);
  except
    Result := errreturn;
  end;
end;

function TIFFcalljpeg_jpeg_read_raw_data(errreturn: Integer; cinfo: PRJpegDecompressStruct; data: Pointer; max_lines:
  Cardinal): Integer; cdecl;
begin
  try
    Result := jpeg_read_raw_data(cinfo, data, max_lines);
  except
    Result := errreturn;
  end;
end;

function TIFFcalljpeg_jpeg_finish_decompress(errreturn: Integer; cinfo: PRJpegDecompressStruct): Integer; cdecl;
begin
  try
    Result := jpeg_finish_decompress(cinfo);
  except
    Result := errreturn;
  end;
end;

function TIFFcallvjpeg_jpeg_abort(cinfo: PRJpegCommonStruct): Integer; cdecl;
begin
  try
    jpeg_abort(cinfo);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_destroy(cinfo: PRJpegCommonStruct): Integer; cdecl;
begin
  try
    jpeg_destroy(cinfo);
    Result := 1;
  except
    Result := 0;
  end;
end;

type
  jpeg_alloc_sarray = function(cinfo: PRJpegCommonStruct; pool_id: Integer; samplesperrow: Cardinal; numrows:
    Cardinal): Pointer; cdecl;

function TIFFcalljpeg_alloc_sarray(alloc_sarray: jpeg_alloc_sarray; cinfo: PRJpegCommonStruct; pool_id: Integer;
  samplesperrow: Cardinal;
  numrows: Cardinal): Pointer; cdecl;
begin
  try
    Result := alloc_sarray(cinfo, pool_id, samplesperrow, numrows);
  except
    Result := nil;
  end;
end;

function TIFFInitJPEG(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_jpeg.obj}

function TIFFInitSGILog(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_luv.obj}

function TIFFInitLZW(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_lzw.obj}

function TIFFInitNeXT(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_next.obj}

function TIFFInitPackBits(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_packbits.obj}

function TIFFInitPixarLog(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_pixarlog.obj}

function TIFFInitThunderScan(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_thunder.obj}
{$L ..\..\Objs\Tiff\tif_version.obj}

function TIFFInitZIP(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_zip.obj}

function NotConfigured(tif: PTIFF; scheme: Integer): Integer; cdecl; external;
const
  _TIFFBuiltinCODECS: array[0..17] of TIFFCodec = (
    (name: 'None'; scheme: COMPRESSION_NONE; init: TIFFInitDumpMode),
    (name: 'LZW'; scheme: COMPRESSION_LZW; init: TIFFInitLZW),
    (name: 'PackBits'; scheme: COMPRESSION_PACKBITS; init: TIFFInitPackBits),
    (name: 'ThunderScan'; scheme: COMPRESSION_THUNDERSCAN; init: TIFFInitThunderScan),
    (name: 'NeXT'; scheme: COMPRESSION_NEXT; init: TIFFInitNeXT),
    (name: 'JPEG'; scheme: COMPRESSION_JPEG; init: TIFFInitJPEG),
    (name: 'Old-style JPEG'; scheme: COMPRESSION_OJPEG; init: NotConfigured),
    (name: 'CCITT RLE'; scheme: COMPRESSION_CCITTRLE; init: TIFFInitCCITTRLE),
    (name: 'CCITT RLE/W'; scheme: COMPRESSION_CCITTRLEW; init: TIFFInitCCITTRLEW),
    (name: 'CCITT Group 3'; scheme: COMPRESSION_CCITTFAX3; init: TIFFInitCCITTFax3),
    (name: 'CCITT Group 4'; scheme: COMPRESSION_CCITTFAX4; init: TIFFInitCCITTFax4),
    (name: 'ISO JBIG'; scheme: COMPRESSION_JBIG; init: NotConfigured),
    (name: 'Deflate'; scheme: COMPRESSION_DEFLATE; init: TIFFInitZIP),
    (name: 'AdobeDeflate'; scheme: COMPRESSION_ADOBE_DEFLATE; init: TIFFInitZIP),
    (name: 'PixarLog'; scheme: COMPRESSION_PIXARLOG; init: TIFFInitPixarLog),
    (name: 'SGILog'; scheme: COMPRESSION_SGILOG; init: TIFFInitSGILog),
    (name: 'SGILog24'; scheme: COMPRESSION_SGILOG24; init: TIFFInitSGILog),
    (name: nil; scheme: 0; init: nil));
{$L ..\..\Objs\Tiff\tif_codec.obj}

function TIFFFileReadProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl; forward;

function TIFFFileWriteProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl; forward;

function TIFFFileSizeProc(Fd: Cardinal): Cardinal; cdecl; forward;

function TIFFFileSeekProc(Fd: Cardinal; Off: Cardinal; Whence: Integer): Cardinal; cdecl; forward;

function TIFFFileCloseProc(Fd: Cardinal): Integer; cdecl; forward;

function TIFFStreamReadProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl; forward;

function TIFFStreamWriteProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl; forward;

function TIFFStreamSizeProc(Fd: Cardinal): Cardinal; cdecl; forward;

function TIFFStreamSeekProc(Fd: Cardinal; Off: Cardinal; Whence: Integer): Cardinal; cdecl; forward;

function TIFFStreamCloseProc(Fd: Cardinal): Integer; cdecl; forward;

function TIFFNoMapProc(Fd: Cardinal; PBase: PPointer; PSize: PCardinal): Integer; cdecl; forward;

procedure TIFFNoUnmapProc(Fd: Cardinal; Base: Pointer; Size: Cardinal); cdecl; forward;

function TIFFFileCloseProc(Fd: Cardinal): Integer; cdecl;
begin
  if CloseHandle(Fd) = True then
    Result := 0
  else
    Result := -1;
end;

function TIFFFileSizeProc(Fd: Cardinal): Cardinal; cdecl;
begin
  Result := GetFileSize(Fd, nil);
end;

function TIFFFileSeekProc(Fd: Cardinal; Off: Cardinal; Whence: Integer): Cardinal; cdecl;
const
  SEEK_SET = 0;
  SEEK_CUR = 1;
  SEEK_END = 2;
var
  MoveMethod: Cardinal;
begin
  if Off = $FFFFFFFF then
  begin
    Result := $FFFFFFFF;
    exit;
  end;
  case Whence of
    SEEK_SET: MoveMethod := FILE_BEGIN;
    SEEK_CUR: MoveMethod := FILE_CURRENT;
    SEEK_END: MoveMethod := FILE_END;
  else
    MoveMethod := FILE_BEGIN;
  end;
  Result := SetFilePointer(Fd, Off, nil, MoveMethod);
end;

function TIFFFileReadProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl;
var
  m: Cardinal;
begin
  if ReadFile(Fd, Buffer^, Cardinal(Size), m, nil) = False then
    Result := 0
  else
    Result := m;
end;

function TIFFFileWriteProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl;
var
  m: Cardinal;
begin
  if WriteFile(Fd, Buffer^, Cardinal(Size), m, nil) = False then
    Result := 0
  else
    Result := m;
end;

function TIFFStreamCloseProc(Fd: Cardinal): Integer; cdecl;
begin
  Result := 0;
end;

function TIFFStreamSizeProc(Fd: Cardinal): Cardinal; cdecl;
begin
  try
    Result := TStream(Fd).Size;
  except
    Result := 0;
  end;
end;

function TIFFStreamSeekProc(Fd: Cardinal; Off: Cardinal; Whence: Integer): Cardinal; cdecl;
const
  SEEK_SET = 0;
  SEEK_CUR = 1;
  SEEK_END = 2;
var
  MoveMethod: Word;
begin
  if Off = $FFFFFFFF then
  begin
    Result := $FFFFFFFF;
    exit;
  end;
  case Whence of
    SEEK_SET: MoveMethod := soFromBeginning;
    SEEK_CUR: MoveMethod := soFromCurrent;
    SEEK_END: MoveMethod := soFromEnd;
  else
    MoveMethod := soFromBeginning;
  end;
  try
    Result := TStream(Fd).Seek(Off, MoveMethod);
  except
    Result := 0;
  end;
end;

function TIFFStreamReadProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl;
begin
  try
    Result := TStream(Fd).Read(Buffer^, Size);
  except
    Result := 0;
  end;
end;

function TIFFStreamWriteProc(Fd: Cardinal; Buffer: Pointer; Size: Integer): Integer; cdecl;
begin
  try
    Result := TStream(Fd).Write(Buffer^, Size);
  except
    Result := 0;
  end;
end;

function TIFFNoMapProc(Fd: Cardinal; PBase: PPointer; PSize: PCardinal): Integer; cdecl;
begin
  Result := 0;
end;

procedure TIFFNoUnmapProc(Fd: Cardinal; Base: Pointer; Size: Cardinal); cdecl;
begin
end;

function TIFFOpen(const Name: AnsiString; const Mode: AnsiString): PTIFF;
const
  Module: AnsiString = 'TIFFOpen';
  O_RDONLY = 0;
  O_WRONLY = 1;
  O_RDWR = 2;
  O_CREAT = $0100;
  O_TRUNC = $0200;
var
  m: Integer;
  wcName: WideString;
  DesiredAccess: Cardinal;
  CreateDisposition: Cardinal;
  FlagsAndAttributes: Cardinal;
  fd: THandle;
begin
  m := _TIFFgetMode(PAnsiChar(Mode), PAnsiChar(Module));
  if m = o_RDONLY then
    DesiredAccess := GENERIC_READ
  else
    DesiredAccess := (GENERIC_READ or GENERIC_WRITE);
  case m of
    O_RDONLY: CreateDisposition := OPEN_EXISTING;
    O_RDWR: CreateDisposition := OPEN_ALWAYS;
    (O_RDWR or O_CREAT): CreateDisposition := OPEN_ALWAYS;
    (O_RDWR or O_TRUNC): CreateDisposition := CREATE_ALWAYS;
    (O_RDWR or O_CREAT or O_TRUNC): CreateDisposition := CREATE_ALWAYS;
  else
    Result := nil;
    exit;
  end;
  if m = O_RDONLY then
    FlagsAndAttributes := FILE_ATTRIBUTE_READONLY
  else
    FlagsAndAttributes := FILE_ATTRIBUTE_NORMAL;
  wcName := WideString(Name);
{$IFDEF FCSUPPORTING}
  fd := CreateFile(PWideChar(wcName), DesiredAccess, FILE_SHARE_READ, nil, CreateDisposition, FlagsAndAttributes, 0);
{$ELSE}
  fd := CreateFile(PChar(Name), DesiredAccess, FILE_SHARE_READ, nil, CreateDisposition, FlagsAndAttributes, 0);
{$ENDIF}
  if fd = INVALID_HANDLE_VALUE then
  begin
{$IFNDEF VOLDVERSION}
    TiffError(PAnsiChar(Module), PAnsiChar('%s: Cannot open'), PAnsiChar(Name));
{$ELSE}
    TiffError(PAnsiChar(Module), PAnsiChar('%s: Cannot open'));
{$ENDIF}
    Result := nil;
    exit;
  end;
  Result := TIFFClientOpen(PAnsiChar(Name), PAnsiChar(Mode), fd, @TIFFFileReadProc, @TIFFFileWriteProc, @TIFFFileSeekProc,
    @TIFFFileCloseProc,
    @TIFFFileSizeProc, @TIFFNoMapProc, @TIFFNoUnmapProc);
  if Result <> nil then
    TIFFSetFileno(Result, fd)
  else
    CloseHandle(fd);
end;

function TIFFOpenStream(const Stream: TStream; const Mode: AnsiString): PTIFF;
var
  m: AnsiString;
begin
  m := 'Stream';
  Result := TIFFClientOpen(PAnsiChar(m), PAnsiChar(Mode), Cardinal(Stream), @TIFFStreamReadProc, @TIFFStreamWriteProc,
    @TIFFStreamSeekProc, @TIFFStreamCloseProc,
    @TIFFStreamSizeProc, @TIFFNoMapProc, @TIFFNoUnmapProc);
  if Result <> nil then TIFFSetFileno(Result, Cardinal(Stream));
end;

initialization
  _TIFFwarningHandler := LibTiffDelphiWarningThrp;
  _TIFFerrorHandler := LibTiffDelphiErrorThrp;

end.