vpdftiff.pas

生成PDF文档的控件

    end;
    Inc(ma);
    Inc(mb);
    Inc(n);
  end;
  Result := 0;
end;

{$IFNDEF VOLDVERSION}
function strcmp(a: Pointer; b: Pointer): Integer; cdecl;
var
  ma, mb: PByte;
begin
  ma := a;
  mb := b;
  while True do
  begin
    if ma^ <> mb^ then
    begin
      if ma^ < mb^ then
        Result := -1
      else
        Result := 1;
      exit;
    end;
    if ma^ = 0 then
    begin
      Result := 0;
      exit;
    end;
    Inc(ma);
    Inc(mb);
  end;
  Result := 0;
end;
{$ENDIF}

function strlen(s: Pointer): Cardinal; cdecl;
var
  m: PByte;
begin
  Result := 0;
  m := s;
  while m^ <> 0 do
  begin
    Inc(Result);
    Inc(m);
  end;
end;

procedure _TIFFfree(p: Pointer); cdecl;
var
  m: TMemoryManager;
begin
  GetMemoryManager(m);
  m.FreeMem(p);
end;

procedure _TIFFmemcpy(d: Pointer; s: Pointer; c: Longint); cdecl;
begin
  CopyMemory(d, s, c);
end;

function pow(x: Double; y: Double): Double; cdecl;
begin
  Result := Power(x, y);
end;

function floor(x: Double): Double; cdecl;
begin
  Result := Trunc(x);
end;

function _TIFFmalloc(s: Longint): Pointer; cdecl;
var
  m: TMemoryManager;
begin
  GetMemoryManager(m);
  Result := m.GetMem(s);
end;

procedure TIFFReadRGBAImageSwapRB(Width, Height: Cardinal; Memory: Pointer);
type
  PCarPoints = ^Cardinal;
var
  m: PCarPoints;
  n: Cardinal;
  o: Cardinal;
begin
  m := Memory;
  for n := 0 to Width * Height - 1 do
  begin
    o := m^;
    m^ := (o and $FF00FF00) or
      ((o and $00FF0000) shr 16) or
      ((o and $000000FF) shl 16);
    Inc(m);
  end;
end;

function LibTiffDelphiVersion: AnsiString;
var
  m: AnsiString;
  na, nb: Integer;
begin
  Result := '';
  m := TIFFGetVersion;
  na := 1;
  while True do
  begin
    nb := na;
    while nb <= Length(m) do
    begin
      if m[nb] = #10 then break;
      Inc(nb);
    end;
    Result := Result + Copy(m, na, nb - na);
    if nb > Length(m) then break;
    Result := Result + #13#10;
    na := nb + 1;
  end;
  Result := Result;
end;

procedure LibTiffDelphiWarningThrp(a: Pointer; b: Pointer; c: Pointer); cdecl;
var
  m: Integer;
  n: AnsiString;
begin
  if @FLibTiffDelphiWarningHandler <> nil then
  begin
    m := sprintfsec(nil, b, @c);
    SetLength(n, m);
    sprintfsec(Pointer(n), b, @c);
    FLibTiffDelphiWarningHandler(PAnsiChar(a), n);
  end;
end;

procedure LibTiffDelphiErrorThrp(a: Pointer; b: Pointer; c: Pointer); cdecl;
var
  m: Integer;
  n: AnsiString;
begin
  if @FLibTiffDelphiErrorHandler <> nil then
  begin
    m := sprintfsec(nil, b, @c);
    SetLength(n, m);
    sprintfsec(Pointer(n), b, @c);
    FLibTiffDelphiErrorHandler(PAnsiChar(a), n);
  end;
end;

function LibTiffDelphiGetWarningHandler: LibTiffDelphiErrorHandler;
begin
  Result := FLibTiffDelphiWarningHandler;
end;

function LibTiffDelphiSetWarningHandler(Handler: LibTiffDelphiErrorHandler): LibTiffDelphiErrorHandler;
begin
  Result := FLibTiffDelphiWarningHandler;
  FLibTiffDelphiWarningHandler := Handler;
end;

function LibTiffDelphiGetErrorHandler: LibTiffDelphiErrorHandler;
begin
  Result := FLibTiffDelphiErrorHandler;
end;

function LibTiffDelphiSetErrorHandler(Handler: LibTiffDelphiErrorHandler): LibTiffDelphiErrorHandler;
begin
  Result := FLibTiffDelphiErrorHandler;
  FLibTiffDelphiErrorHandler := Handler;
end;

procedure _TIFFSwab16BitData(tif: Pointer; buf: Pointer; cc: Integer); cdecl; external;

procedure _TIFFSwab32BitData(tif: Pointer; buf: Pointer; cc: Integer); cdecl; external;

procedure _TIFFSwab64BitData(tif: Pointer; buf: Pointer; cc: Integer); cdecl; external;

procedure _TIFFNoPostDecode(tif: Pointer; buf: Pointer; cc: Integer); cdecl; external;

function TIFFReadTile(tif: Pointer; buf: Pointer; x: Cardinal; y: Cardinal; z: Cardinal; s: Word): Integer; cdecl; external;

{$L ..\..\Objs\Tiff\tif_read.obj}

function _TIFFSampleToTagType(tif: Pointer): Integer; cdecl; external;

procedure _TIFFSetupFieldInfo(tif: Pointer); cdecl; external;

function _TIFFCreateAnonFieldInfo(tif: Pointer; tag: Cardinal; field_type: Integer): Pointer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_dirinfo.obj}
{$L ..\..\Objs\Tiff\tif_dirwrite.obj}
{$L ..\..\Objs\Tiff\tif_flush.obj}

function TIFFFlushData1(tif: Pointer): Integer; cdecl; external;

function TIFFSetupStrips(tif: Pointer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_write.obj}

function TIFFInitDumpMode(tif: Pointer; scheme: Integer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_dumpmode.obj}

function TIFFSetCompressionScheme(tif: Pointer; scheme: Integer): Integer; cdecl; external;

procedure _TIFFSetDefaultCompressionState(tif: Pointer); cdecl; external;
{$L ..\..\Objs\Tiff\tif_compress.obj}
{$L ..\..\Objs\Tiff\tif_dirread.obj}

procedure TIFFFreeDirectory(tif: Pointer); cdecl; external;

function TIFFDefaultDirectory(tif: Pointer): Integer; cdecl; external;

function TIFFReassignTagToIgnore(task: Integer; TIFFtagID: Integer): Integer; cdecl; external;

procedure _TIFFsetString(cpp: Pointer; cp: Pointer); cdecl; external;

procedure _TIFFsetByteArray(vpp: Pointer; vp: Pointer; n: Integer); cdecl; external;
{$L ..\..\Objs\Tiff\tif_dir.obj}

function TIFFVGetFieldDefaulted(tif: Pointer; tag: Cardinal; ap: Pointer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_aux.obj}

procedure TIFFCIELabToXYZ(cielab: Pointer; l: Cardinal; a: Integer; b: Integer; X: Pointer; Y: Pointer; Z: Pointer); cdecl; external;

procedure TIFFXYZToRGB(cielab: Pointer; X: Single; Y: Single; Z: Single; r: Pointer; g: Pointer; b: Pointer); cdecl; external;

procedure TIFFYCbCrtoRGB(ycbcr: Pointer; Y: Cardinal; Cb: Integer; Cr: Integer; r: Pointer; g: Pointer; b: Pointer); cdecl; external;

function TIFFYCbCrToRGBInit(ycbcr: Pointer; luma: Pointer; refBlackWhite: Pointer): Integer; cdecl; external;

function TIFFCIELabToRGBInit(cielab: Pointer; display: Pointer; refWhite: Pointer): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_color.obj}
{$L ..\..\Objs\Tiff\tif_close.obj}
{$L ..\..\Objs\Tiff\tif_extension.obj}

function _TIFFgetMode(mode: PAnsiChar; module: PAnsiChar): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_open.obj}
{$L ..\..\Objs\Tiff\tif_getimage.obj}

function TIFFPredictorInit(tif: PTIFF): Integer; cdecl; external;
{$L ..\..\Objs\Tiff\tif_predict.obj}
{$L ..\..\Objs\Tiff\tif_print.obj}
{$L ..\..\Objs\Tiff\tif_error.obj}

function _TIFFDefaultStripSize(tif: Pointer; s: Cardinal): Cardinal; cdecl; external;
{$L ..\..\Objs\Tiff\tif_strip.obj}
{$L ..\..\Objs\Tiff\tif_swab.obj}

function TIFFCheckTile(tif: Pointer; x: Cardinal; y: Cardinal; z: Cardinal; s: Word): Integer; cdecl; external;

procedure _TIFFDefaultTileSize(tif: Pointer; tw: Pointer; th: Pointer); cdecl; external;
{$L ..\..\Objs\Tiff\tif_tile.obj}
{$L ..\..\Objs\Tiff\tif_warning.obj}

function TIFFInitCCITTRLE(tif: PTIFF; scheme: Integer): Integer; cdecl; external;

function TIFFInitCCITTRLEW(tif: PTIFF; scheme: Integer): Integer; cdecl; external;

function TIFFInitCCITTFax3(tif: PTIFF; scheme: Integer): Integer; cdecl; external;

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

procedure TIFFjpeg_error_exit_raise; cdecl;
begin
  raise Exception.Create('TIFFjpeg_error_exit');
end;

function TIFFcallvjpeg_jpeg_CreateCompress(cinfo: Pointer; version: Integer; structsize: Cardinal): Integer; cdecl;
begin
  try
    jpeg_CreateCompress(cinfo, version, structsize);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_CreateDecompress(cinfo: Pointer; version: Integer; structsize: Cardinal): Integer; cdecl;
begin
  try
    jpeg_CreateDecompress(cinfo, version, structsize);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_set_defaults(cinfo: Pointer): Integer; cdecl;
begin
  try
    jpeg_set_defaults(cinfo);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_set_colorspace(cinfo: Pointer; colorspace: Integer): Integer; cdecl;
begin
  try
    jpeg_set_colorspace(cinfo, colorspace);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_set_quality(cinfo: Pointer; quality: Integer; force_baseline: Byte): Integer; cdecl;
begin
  try
    jpeg_set_quality(cinfo, quality, force_baseline);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_suppress_tables(cinfo: PRJpegCompressStruct; suppress: Byte): Integer; cdecl;
begin
  try
    jpeg_suppress_tables(cinfo, suppress);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcallvjpeg_jpeg_start_compress(cinfo: PRJpegCompressStruct; write_all_tables: Byte): Integer; cdecl;
begin
  try
    jpeg_start_compress(cinfo, write_all_tables);
    Result := 1;
  except
    Result := 0;
  end;
end;

function TIFFcalljpeg_jpeg_write_scanlines(errreturn: Integer; cinfo: PRJpegCompressStruct; scanlines: Pointer;
  num_lines: Cardinal): Integer; cdecl;
begin
  try
    Result := jpeg_write_scanlines(cinfo, scanlines, num_lines);
  except
    Result := errreturn;
  end;
end;

function TIFFcalljpeg_jpeg_write_raw_data(errreturn: Integer; cinfo: PRJpegCompressStruct; data: Pointer; num_lines:
  Cardinal): Integer; cdecl;
begin
  try
    Result := jpeg_write_raw_data(cinfo, data, num_lines);
  except
    Result := errreturn;
  end;
end;

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