Форум на Исходниках.RU

(* -- программа работает без формы! -- *)

(* выбираем из текущей директории все TIFF файлы *)

(* для каждого TIFF файла читаем теги *)

(* и выводим их в текстовый файл TIFF.TXT *)

program TIFFTags;

uses Windows, Classes, SysUtils;

type

TDirRec = class (TObject)

Attr: word;

Time: Longint;

Size: Longint;

Name: string[255];

end;

TDirList = class(TList)

procedure Done; (* освободить память *)

procedure CollectExt(aPath:string;sExt:string); (* собрать по Ext *)

procedure CollectTpl(PathTpl:string); (* добавить файлы соотв-щие шаблону *)

end; (* TDirList *)

(*============================================================================*)

(* служебные функции *)

procedure WarnAbs(S:string); (* неподавляемый WARN *)

begin

MessageBox(GetActiveWindow,PChar(S),

PChar('ПРЕДУПРЕЖДЕНИЕ ИЛИ НАПОМИНАНИЕ'),MB_OK);

end;

function AddBackSlashForce(Path:string):string;

(* проверяет, что Path - именно каталог, а не файл, добавляет '\' в конец *)

begin

if length(Path) = 0 then begin result := Path; Exit; end; (* Current Path *)

if Path[Length(Path)] <> '\' then

if Not SysUtils.FileExists(Path) then Path := Path + '\';

Result := Path;

end;

(*============================================================================*)

(* перебор файлов в текущей поддиректории *)

procedure TDirList.Done;

var D : TDirRec; I : integer;

begin

for I := Self.Count-1 downto 0 do begin

D := TDirRec(Items[I]);

D.Name := ''; (* освобождаем память, занятую строкой *)

D.Free;

Self.Delete(I);

end;

procedure TDirList.CollectTpl(PathTpl:string);

var F : TSearchRec;

D : TDirRec;

DosError : integer;

begin

DosError :=

FindFirst(PathTpl, faReadOnly + faHidden + faDirectory + faArchive, F);

while (DosError = 0) do begin

D := TDirRec.Create;

D.Attr := F.Attr;

D.Time := F.Time;

D.Size := F.Size;

D.Name := F.Name;

Add(D);

DosError := FindNext(F);

end;

FindClose(F);

end;

procedure TDirList.CollectExt(aPath:string;sExt:string);

var PathTpl : string;

begin

if Not DirectoryExists(aPath) then begin

WARNAbs('DirList.CollectExt: Path <'+aPath+'> Not found!'); Exit;

end;

if Count <> 0 then Done; (* "забыть" предыдущую коллекцию файлов *)

aPath := AddBackSlashForce(aPath);

PathTpl := aPath +'*.' + sExt; (* шаблон для FindFirst/FindNext *)

CollectTpl(PathTpl);

end;

(*============================================================================*)

(* строковые функции *)

const hexChars: array [0..$F] of char = '0123456789ABCDEF';

function HexB(B:byte):string;

begin HexB:=hexChars[B shr 4]+hexChars[B and $F] end;

function HexW(W:word):string;

begin HexW:=HexB(Hi(W))+HexB(Lo(W)) end;

function ISt(I:Int64):string;

begin result := IntToStr(I) end;

function NSt(I:longint;D:integer):string;(*ЦЕЛОЕ В СТРОКУ С ВЕДУЩИМИ пробелами*)

var S : string;

begin

Str(I,S);

if length(S) > D then S := copy(S,length(S)-D+1,D); (* правая часть *)

while length(S) < D do S := ' '+S;

NSt := S;

end;

function SSt(S:string;N:integer):string;

var L : integer;

begin

L := length(S);

if L < N then begin SetLength(S,N); FillChar(S[L+1],N-L,' '); end;

result := S;

end;

(*============================================================================*)

(* главная процедура *)

procedure ExploreTiff;

var fo : System.Text; (* выходной файл *)

fi : file of word; (* для входных TIFF - файлов *)

fno : string; (* имя выходного файла *)

fni : string; (* имя исследуемого файла *)

aDir : TDirList;(* для сбора списка TIFF - файлов *)

aFil : TDirRec; (* данные текущего файла *)

sDir : string; (* имя текущего каталога *)

S,S1,S2,S3 : string;

ITiff : integer;

ITag : integer;

NTag : integer;

W : word;

WA : packed array[1..2] of word;

N2 : DWORD absolute WA;

WId : word;

WTy : word;

LNa : integer; (* макс.длина имени файла *)

L2,L3 : integer;

begin

fno := 'TIFF.txt';

aDir := TDirList.Create;

sDir := SysUtils.GetCurrentDir;

aDir.CollectExt(sDir,'tif');

Assign(fo,fno);

rewrite(fo);

LNa := 0;

for ITiff := 0 to aDir.Count-1 do begin

aFil := aDir.Get(ITiff);

fni := aFil.Name;

if LNa < length(fni) then LNa := length(fni);

end;

S1 := 'имя файла '; S2 := 'порядок_байт '; S3 := 'Версия ';

if LNa < length(S1) then LNa := length(S1);

LNa := LNa + 1;

L2 := length(S2);

L3 := length(S3);

S := SSt(S1,LNa)+S2+S3+'Оффсет_IDF Тэгов';

writeln(fo,S);

S := SSt('умолчания:',LNa)+SSt('49',L2)+SSt('{text}2A',L3)+'{text}000008 19';

writeln(fo,S);

for ITiff := 0 to aDir.Count-1 do begin

aFil := aDir.Get(ITiff);

fni := aFil.Name;

S := SSt(fni,LNa);

Assign(fi,fni);

Reset(fi);

read(fi,W); S := S + SSt('$'+HexW(W),L2); (* порядок байт *)

read(fi,W); S := S + SSt('$'+HexW(W),L3); (* версия TIFF *)

read(fi,WA[1]); (* offset IDF *)

read(fi,WA[2]); (* offset IDF *)

S := S + '$'+HexW(WA[2])+HexW(WA[1])+' ';

read(fi,W); S := S + ISt(W); (* число тегов *)

writeln(fo,S);

System.Close(fi);

end;

for ITiff := 0 to aDir.Count-1 do begin

aFil := aDir.Get(ITiff);

fni := aFil.Name;

(* далее открываем двоичный файл, чтобы прочитать теги *)

Assign(fi,fni);

Reset(fi);

read(fi,W);

read(fi,WA[1]);

read(fi,WA[2]);

read(fi,W);

NTag := W;

writeln(fo);

writeln(fo,SSt(fni,LNa)+'ТЭГИ ---------------------');

// 34 34 2000000000 341234

S := ' № Id_тега DataType NValue Offset/Value';

writeln(fo,S);

for ITag := 1 to NTag do begin

read(fi,WId);

read(fi,WTy);

read(fi,WA[1]);

read(fi,WA[2]);

S := NSt(ITag,3)+' $'+HexW(WId)+' $'+HexW(WTy)+' '+ NSt(N2,10);

read(fi,WA[1]);

read(fi,WA[2]);

S := S+' $'+HexW(WA[2])+HexW(WA[1])+' '+NSt(N2,10);

writeln(fo,S);

end;

System.Close(fi);

end;

System.Close(fo);

end; (* ExploreTiff *)

Begin

ExploreTiff;

End.