批量将彩色tif文件进行压缩成一个文件，200分全给！！(200分)

我现在急需将指定目录下的彩色tif文件进行压缩打包成一个自定义文件（.pak），且可以通过image查看。我这里有部分原来对黑白bmp图片实现的源代码，希望大家指点如何改动，支持其对彩色tif压缩。
由于本人水平有限，请尽量详细，多多见谅！！
procedure TfrmScan.btnPackClick(Sender: TObject);
begin
bSucc := PackAna(editAnaCode.Text);
Screen.Cursor := crDefault;
if bSucc then
Application.MessageBox('打包成功','系统提示',MB_OK+MB_ICONINFORMATION)
else
begin
Application.MessageBox('打包失败','系统提示',MB_OK+MB_ICONINFORMATION);
DeleteFile(packpath+editAnaCode.Text+'.pak');
end;end;

function TFrmScan.PackAna(Path : string): Boolean;
var
RealPath : string;
FindPath : string; //to find *.bmp
FindName : string; //the file name to be found
tempName : Integer; //index of file to be found
ErrMsg : string;
PackFileName : string; //the name of the pack file
hSubDir : Integer; //the handle of the pack file of the subdir
hTemp : Integer; //temp handle of the file in the subdir
FileNum : Integer; //file number in the subdir
FindOut : Integer; //result of function FindFirst and FindNext
Offset : Integer; //offset of the file pointer position
F : TSearchRec; //get the result of FindFirst and FindNext
Step : Integer; //step of the offset when write file
buf : Pointer; //buffer to read and write
i : Integer;
nTag : Integer;
nTotalScan : Integer;
nTotalPack: Integer;
strErrMsg : string;
One : Integer;
zero : Integer; //init the file header of file length
realRead : Integer; //the real count of the buffer read
//or the real count of the buffer write
TjDir : string;
HyDir : string;
strTemp : string ;
copy_path :string ;

begin
if FileExists(packpath + path+'.pak') then
begin
strTemp := '打包文件';
strTemp := strTemp + packpath + path +'.pak';
strTemp := strTemp + '已经存在，是否覆盖?';
if MessageBox(0,PChar(strTemp),'系统提示',MB_OKCANCEL+MB_ICONQUESTION)=IDCANCEL then
exit;
end;
copy_path := copy(packpath,1,length(packpath) - 1);
{$I-}
IOResult;
chdir(copy_path);
{$I+}
Result := False;
One := 1;
zero := 0; //define the Result to False
RealPath := tmppath+Path; //combine the path of the file location

FindPath:=RealPath+'/*.tif';
nTotalScan:=FilesInDir(FindPath);

//begin to pack
try
{$I-}
chdir(RealPath); // cd realpath
{I+}
Except
//if IOResult<>0 then //dir not exist
ErrMsg:='路径 '+RealPath+' 不存在!';
ErrBox(PChar(ErrMsg));
Result := False;
exit;
end;

//if SavePackDlg.Execute then
PackFileName := packpath + path + '.pak';

//get the number of files in the subdir
FindPath:=RealPath+'/*.tif';
FileNum:=FilesInDir(FindPath);

hSubDir:=FileCreate(PackFileName); //create a new pack file
if hSubDir = 0 then
begin
ErrMsg:='创建包文件 '+PackFileName + ' 时出错！';
ErrBox(PChar(ErrMsg));
Result := False;
exit;
end;

//initlize the file header
FileWrite(hSubDir,'CAPE',4); //identify of CAPE Corp.
FileSeek(hSubDir,4,0);
FileWrite(hSubDir,FileNum,4); //write the file count into the PackFile
//init the file header and fill the length with number 0
zero:=0;
FileWrite(hSubDir,zero,4*FileNum); //Init the FileLen with 0

//写入标志位，可以不用，直接根据后面的首页码的值也可以判断
//write the tag of the existence of the content
for i := 1 to 15 do
begin
if tagExist <> 0 then
FileWrite(hSubDir,One,2)
else
FileWrite(hSubDir,zero,2);
end;

//write the first page number of each content, zero if not exists
for i:= 1 to 15 do
FileWrite(hSubDir,tagExist,2);

//then find the *.tif and wrote them into the pack file
FindName := RealPath + '/1.tif';
TempName := 1;
FindOut:=FindFirst(FindName,$0000003F,F);
Offset:=4;
Step:=4;
while FindOut=0 do
begin
//write file length into the file header
Offset:=Offset+Step; //for fileseek
FileSeek(hSubDir,Offset,0); //locate the file pointer to write the file length
FileWrite(hSubDir,F.Size,4); //write the file len into the file header

//write found file date into pack file
//first read the .tif file to a buffer
hTemp:=FileOpen(FindName,fmOpenRead);
if hTemp <= 0 then
begin
ErrBox('病案打包过程中出现打开件错误');
FileClose(hSubDir);
exit;
end;

GetMem(buf,BufSize);
realRead:=FileRead(hTemp,buf^,F.Size);
if realRead <> F.Size then
begin
ErrBox('病案子包打包过程中出现读取文件错误');
FileClose(hSubDir);
exit;
end;

//then write the buffer into pack file
FileSeek(hSubDir,0,2); //move the file pointer to the end of the file
realRead := FileWrite(hSubDir,buf^,F.Size);
if realRead <> F.Size then
begin
ErrBox('病案子包打包过程中出现写文件错误');
FileClose(hSubDir);
exit;
end;

FreeMem(buf);
FileClose(hTemp);

FindClose(F);
TempName := TempName +1;
FindName := RealPath + '/'+IntToStr(TempName)+'.tif';
FindOut:=FindFirst(FindName,$0000003F,F);
end;

//if the fileNum which has been packed <> nTotalFile in the directory, Error
nTotalPack := TempName - 1;
if nTotalPack <> nTotalScan then
begin
strErrMsg := '该病案共扫描了 ';
strErrMsg := strErrMsg + IntToStr(nTotalScan);
strErrMsg := strErrMsg + ' 页，打包过程共打包了 ';
strErrMsg := strErrMsg + IntToStr(nTotalPack);
strErrMsg := strErrMsg + ' 页，打包过程出现错误';
ErrBox(PChar(strErrMsg));
FileClose(hSubDir);
exit;
end;

FindClose(F); //end of find

FileClose(hSubDir); //close the pack file
Result := True;
end;

程序开始调用了'imglib.dll'
//Load ImgLib.dll for the purpose of converting the image type
dllName := 'imglib.dll';
hImg := LoadLibrary(dllName);
@ReadFileIntoDIB := GetProcAddress(hImg,'ReadFileIntoDIB');
@WriteDIBToFile := GetProcAddress(hImg,'WriteDIBToFile');
@ZoomDIB := GetProcAddress(hImg,'ZoomDIB');
@MirrorDIB := GetProcAddress(hImg,'MirrorDIB');
@RotateDIB := GetProcAddress(hImg,'RotateDIB');
@GetLastImgLibError := GetProcAddress(hImg,'GetLastImgLibError');
@DIBFree := GetProcAddress(hImg,'DIBFree');

写信至xiniu79@sina.com,我有解决办法。

接受答案了.