Zip File view

{programme repris pour char edit
  realise par
    charles vidal
    pour toutes suggestions
    email : [[Email Removed]]
}

{? Fido Pascal Conference ?????????????????????????????????????????????? PASCAL ?
Msg  : 580 of 708
From : David Drzyzga                       1:3612/220.0         25 Apr 93  07:28
To   : Dustin Nulf                         1:124/6304.0
Subj : User defined Character S
????????????????????????????????????????????????????????????????????????????????
 DN> Is there any way to create or use your own fonts in
 DN> regular text mode with Pascal?

Yep. Here's a demo of a routine originally posted by Bernie P and revised by me:}

program testfont;
{-upsidedown and backwards text aka redefining the text mode font}
uses crt;
type charset = array[0..255,1..16] of byte;
var  newcharset, oldcharset : charset;
     fichier:file of charset;
procedure getoldcharset;
var
  b:byte;
  w:word;
begin
  for b := 0 to 255 do begin
    w := b * 32;
    inline($FA);
    PortW[$3C4] := $0402;
    PortW[$3C4] := $0704;
    PortW[$3CE] := $0204;
    PortW[$3CE] := $0005;
    PortW[$3CE] := $0006;
    Move(Ptr($A000, w)^, oldcharset[b,1], 16);
    PortW[$3C4] := $0302;
    PortW[$3C4] := $0304;
    PortW[$3CE] := $0004;
    PortW[$3CE] := $1005;
    PortW[$3CE] := $0E06;
    inline($FB);
  end;
end;

procedure restoreoldcharset;
var
  b:byte;
  w:word;
begin
  for b := 0 to 255 do begin
    w := b * 32;
    inline($FA);
    PortW[$3C4] := $0402;
    PortW[$3C4] := $0704;
    PortW[$3CE] := $0204;
    PortW[$3CE] := $0005;
    PortW[$3CE] := $0006;
    Move(oldcharset[b,1], Ptr($A000, w)^, 16);
    PortW[$3C4] := $0302;
    PortW[$3C4] := $0304;
    PortW[$3CE] := $0004;
    PortW[$3CE] := $1005;
    PortW[$3CE] := $0E06;
    inline($FB);
  end;
end;

procedure setasciichar(charnum : byte; var data);
var
   offset : Word;
begin
  offset := charNum * 32;
  inline($FA);
  PortW[$3C4] := $0402;
  PortW[$3C4] := $0704;
  PortW[$3CE] := $0204;
  PortW[$3CE] := $0005;
  PortW[$3CE] := $0006;
  Move(data, Ptr($A000, offset)^, 16);
  PortW[$3C4] := $0302;
  PortW[$3C4] := $0304;
  PortW[$3CE] := $0004;
  PortW[$3CE] := $1005;
  PortW[$3CE] := $0E06;
  inline($FB);
end;
{-------------------------------------------}
procedure aff_car;
var i:byte;
begin
  ClrScr;
  GotoXY( 1, 1 );
  for i := 0 to 255 do         { Affiche le jeu complet des caract?res }
    begin
      GotoXY( i mod 13 * 6 + 2, i div 13 + 1 );
      write( i:3 , ':' );
      if ( i <> 13 ) and ( i <> 10 ) and ( i <> 7 ) then
       write( chr( i ) );
    end;
    GotoXY( 3, 22 );
    writeln('Test Font '+paramstr(1)+' Charles vidal ' );
    write('  Pour toutes suggestions [[Email Removed]]');
end;
{---------------------------------------------}
var
  b,c : byte;

begin
  if paramcount=0 then
                   begin
                       writeln('entrez le nom de la font (.fnt)');
                       halt(1);
                   end;
  getoldcharset;
   assign(Fichier,paramstr(1));
   reset(Fichier);
   read(Fichier,newcharset);
   close(fichier);
  for b := 0 to 255 do setasciichar(b,newcharset[b,1]);
  aff_car;
  readln;
  restoreoldcharset;
end.
{Have fun...}