uses dos; type billede = record stor:longint; navn:string[255]; end; const {$ifdef fpc} {$hints on} {$hint FPC compiler directive encountered} arraymax = 255; {$else} arraymax = $40; {$endif x} fn2 = 'index.html'; dirnum: byte = 1; jpgnum: byte = 1; updirs: byte = 0; upfile: byte = 0; docs : byte = 0; nindex: boolean = false; name = 'Pictlinx ver 3.2 with slideshow - www.hjelmenet.dk/software'; test = false; striplead = 'm_'; var hf : file; f2,f3 : text; title,title2,s: string; dirinfo : searchrec; dirs : array[0..255] of string[arraymax]; jpgs : array[0..255] of billede; sort : array[0..255] of billede; a,b,fsort,fsive : byte; m1,yy,mm,dd,wd,hh,min,sek,s100 : word; c : char; ftid : datetime; flere : boolean; {$ifndef fpc} {$i c:\pascal\tpas\upcase.pas} {$i c:\pascal\tal2.pas} function lowercase(u:string):string; begin downstr(u); lowercase:=u; end; {$endif} {$i tal2.pas} procedure findhtm(start:string;const ext:string); var a : byte; begin FindFirst(start+'*.*',$3f, DirInfo); { Same as DIR *.PAS } while DosError = 0 do begin s:=lowercase(dirinfo.name); if (dirinfo.attr<>$10) and (copy(s,1,4)<>'zdia') and (pos('.'+ext,s)>0) and (pos('index.txt',s)=0 )then begin if start+s<>start+dirinfo.name then begin inc(upfile); writeln(start+dirinfo.name,^G); end; sort[fsort].navn:=start+dirinfo.name; a:=fsort; while (a>1) and (sort[a].navn'); for x:=1 to length(s) do if s[x]='&' then write(f2,'&') else filter(s[x]); if s='' then write(f2,' '); write(f2,''); end; {procedure slide(x:word; var sln:shortstring); var nx : shortstring; begin assign(f3,'zdia'+tal(a,4)+'.html'); rewrite(f3); write(f3,'',^M^J,'',^M^J,'',^M^J); write(f3,'',sln,'',^M^J); write(f3,'',^M^J^M^J,'',^M^J); if a

'); if a>1 then nx:='zdia'+tal(pred(a),4)+'.html' else nx:='index.html'; writeln(f3,'Click anywhere in the picture for next or here for previous or exit slideshow',^J^M,''); close(f3); end; } procedure slide(x:word; var sln:shortstring); var nx : shortstring; begin assign(f3,'zdia'+tal(a,4)+'.html'); rewrite(f3); writeln(f3,'',^M^J,''); writeln(f3,'',sln,'',^M^J); write(f3,'',^M^J^M^J,'',^M^J,''+^M^J+''); if a>1 then writeln(f3,''); writeln(f3,''); if a  Next  '); writeln(f3,'
  Back     Exit   

'); writeln(f3,'

'+^J^M+''); close(f3); end; begin { ================== MAIN ===================== } writeln(name); if boolean(pos('?',paramstr(1))) then begin writeln; writeln('Pictlinx is the successor to pictlist.pas now written for Freepascal'); writeln('(www.freepascal.org) and can be compiled into either Win95 or Linux.'); writeln; writeln('Pictlinx will start from the current directory and search for any jpg or gif.'); writeln('If found, it will then search any subdirectories one level deep for thumbnails'); writeln('with matching filenames and create or overwrite the file index.html from this.'); writeln('Thumbnail files are not created by Pictlinx, but should be created elsewhere.'); writeln; writeln('Pictlinx will also search subdirectories and the parent directory, but not'); writeln('the current directory, for any *.htm or *.html-files and make links to them.'); writeln; writeln('Pictlinx will search for a file named index.txt in the current directory.'); writeln('The first line of text is made into the title and header of the index.html'); writeln('file and any following lines will be added into the document as plain text.'); writeln; writeln('Version 1.2 pictlinx will add the system date and time.'); writeln; writeln('Version 1.4 pictlinx will also scan for *.doc, *.xls and *.mp* files in'); writeln('the current directory.'); writeln; writeln('Version 1.5 minor bugfix when processing files both with and without thumbnails'); writeln; writeln('Version 1.6 pictlinx will also scan for *.txt, *.pp and *.pas files in'); writeln('the current directory.'); writeln; writeln('Version 2.0 updated to FPC 2.0 fixed some bugs and add time and size to files.'); writeln; writeln('Case is significant under Linux. Pictlinx will not convert any filenames but'); writeln('prints a warning if any uppercase file- or directory names are encountered.'); writeln('Filenames can be renamed into lowercase with the tool ren_file written by me.'); writeln; writeln('The programme will not accept any parameters except -? printing this help.'); writeln; writeln('Known bugs: Pictlinx can''t handle more than 255 files or 255 directories.'); writeln; writeln('The programme is freeware and is supplied as is, without any warranty at all.'); writeln; writeln('Feedback is much appreciated. http://www.hjelmenet.dk'); halt(1); end; s:=paramstr(1); if boolean(pos('\',s)) then begin while s[length(s)]<>'\' do delete(s,length(s),1); delete(s,length(s),1); chdir(s); writeln('Directory changed to : '+s); end; assign(f2,fn2); {$i-} rewrite(f2); {$i+} if boolean(ioresult) then begin writeln('Unable to create ',fn2,^G); halt(1); end; { ================== GET AND RENAME DIRS ===================== } FindFirst('*',$3f, DirInfo); { Same as DIR *.PAS } while DosError = 0 do begin if (dirinfo.attr=$10) and (dirinfo.name[1]<>'.') then begin if lowercase(dirinfo.name)<>dirinfo.name then begin writeln(dirinfo.name,^G); inc(updirs); end; dirs[dirnum]:=dirinfo.name; a:=dirnum; while (a>1) and (dirs[a]'.') then begin if lowercase(dirinfo.name)<>dirinfo.name then begin writeln(dirinfo.name,^G); inc(updirs); end; dirs[dirnum]:=dirinfo.name; a:=dirnum; while (a>1) and (dirs[a]^J) do begin read(c); case c of ^M,^J : ; else title:=title+c; end; { case } end; write(f2,'',^M^J,'',^M^J,'',^M^J); if title>'' then begin write(f2,''); wtitle; write(f2,'',^M^J); end; write(f2,'',^M^J^M^J,'',^M^J); if title>'' then begin write(f2,'

'); wtitle; write(f2,'

',^M^J); end; if not (nindex or seekeof) then begin while not eof(input) do begin read(c); case c of ^M : ; ^J : write(f2,'
',^M^J); else filter(c); end; { case } end; write(f2,'

',^M^J); end; {$i-} close(input); {$i+} m1:=ioresult; assign(input,''); reset(input); { ======================= GET JPG-FILENAMES ========================== } FindFirst('*.*',$3f, DirInfo); { Same as DIR *.PAS } while DosError = 0 do begin s:=lowercase(dirinfo.name); if (pos('.jp',s)>0) or (pos('.gif',s)>0) then begin if s<>dirinfo.name then begin writeln(dirinfo.name,^G); inc(upfile); end; jpgs[jpgnum].navn:=dirinfo.name; jpgs[jpgnum].stor:=dirinfo.size; a:=jpgnum; while (a>1) and (jpgs[a].navn1) and (sort[fsive].stor'^M^J); slide(a,jpgs[a].navn); end else begin {_blank} write(f2,'',sort[2].navn,' ',sort[2].stor,' bytes'); slide(a,sort[2].navn); fsort:=3; while sort[fsort].navn<>'' do begin write(f2,'.'); inc(fsort); end; write(f2,^M^J); end; end; { ====================== FIND HTM* ==================== } {$i-} close(input); {$i+} m1:=ioresult; fillchar(sort,sizeof(sort),0); fsort:=1; getdir(0,s); if length(s)>3 then findhtm('../','htm'); findhtm('','doc'); findhtm('','txt'); findhtm('','mp'); findhtm('','xls'); findhtm('','pp'); findhtm('','pas'); findhtm('','exe'); findhtm('','swf'); findhtm('','wmv'); for a:= 1 to pred(dirnum) do findhtm(dirs[a]+'/','htm'); write(f2,'',^M^J); if jpgnum>2 then writeln(f2,''); for a:=1 to fsort do if sort[a].navn>'' then begin write(f2,''); s:=''; title2:=''; if pos('.doc',sort[a].navn)>0 then title2:='Word document'; if pos('.txt',sort[a].navn)>0 then title2:='Text file'; if pos('.xls',sort[a].navn)>0 then title2:='Excel regneark'; if pos('.mp' ,sort[a].navn)>0 then title2:='mp* file'; if pos('.pas',sort[a].navn)>0 then title2:='Turbo Pascal source file'; if pos('.pp' ,sort[a].navn)>0 then title2:='Free Pascal source file'; if pos('.exe' ,sort[a].navn)>0 then title2:='Binary executable'; assign(input,sort[a].navn); {$i-} reset(input); {$i+} if boolean(ioresult) then s:='could not be accessed' else begin if pos('.htm',sort[a].navn)>0 then begin while (not seekeof) and (pos('',s)=0) do readln(s); if boolean(pos('<title>',s)) then begin delete(s,1,6+pos('<title>',s)); delete(s,pos('',s),$ff); title2:=s; end; end; if (pos('.pp',sort[a].navn)>0) or (pos('.pas',sort[a].navn)>0) then begin while (not seekeof) and (pos('name',s)=0) do readln(s); if boolean(pos('name',s)) and boolean(pos('=',s)) then begin delete(s,1,pos('''',s)); while s[1]<'!' do delete(s,1,1); while pos('''',s)>0 do delete(s,pos('''',s),1); while pos(';',s)>0 do delete(s,pos(';',s),1); title2:=s; end; end; end; inc(docs); rtitle(title2); findfirst(sort[a].navn,$3f,dirinfo); unpacktime(dirinfo.time,ftid); write(f2,''); findclose(dirinfo); write(f2,'',^M^J); close(input); end; getdate(yy,mm,dd,wd); gettime(hh,min,sek,s100); write(f2,'
   
Slideshow 
',sort[a].navn,'',tal(ftid.year,4),tal(ftid.month,2),tal(ftid.day,2),'',tal(ftid.hour,2),':',tal(ftid.min,2), 'size',dirinfo.size,'

',name,' - ',tal(yy,4),tal(mm,2),tal(dd,2), ' ',tal(hh,2),':',tal(min,2),''^M^J); close(f2); {$i-} close(input); {$i+} m1:=ioresult; assign(input,''); reset(input); if test or boolean(updirs) or boolean(upfile) then begin writeln(upfile,' files and ',updirs,' directories upcase'^G); writeln(pred(jpgnum),' files and ',pred(dirnum),' directories plus ',docs,' other documents found'^J); { writeln; for mm:=0 to dirnum do writeln(mm,^I,'>',dirs[mm],'<'); } readln; end; end.