TextScreen to .BMP


Unit Scr2Bmp; {TP 6}

{by Franz Glaser, Austria   meg-glaser@eunet.at}

{Save textscreen 80x25 VGA to .BMP files, using VGA character set and 16 colors.  The unit is intended to be included in a main program, for creation of manuals or advertisements or homepages (convert .BMP to .GIF with a paint program).  The unit is an extension of the graphic mode Graph2BMP16 with charset painting.

 The unit writes to sequential files numbered
  SCRV0000.BMP
  SCRV0001.BMP etc. in the current (at start) directory.

 The unit is usually included with some {$IFDEF SCRSHOT} in the application program's Uses line.

Drawback: exception chars (wide 9-pixel chars) are not used, on most VGA cards the 'M' and several other chars are painted extra wide on the CRT, but not here in the .BMP file. This is due to the fact that the .BMP is not painted with 720 pixels, but with 640, where each char can be only 8 pixels wide. The 720 pixel mode would lead to an unwanted w/h aspect ratio of the whole .BMP image.

The unit is limited to 80x25 VGA TEXTmode screens. It is much work to enhance it to 80x43 or similar textmodes}

Interface

Uses CRT,DOS;

{this is the only interface procedure. It must be called on some function key or HandleEvent}
Procedure Screen2BMP;

Implementation

Type  TCSet    = Array[0..15] of Byte; {1 char}
      TCharSet = Array[#0..#255] of TCSet;
      PCharSet = ^TCharSet;
      Str7     = String[7];
      TChr     = Record
                   Bu : Char;  {German: Buchstabe, Farbe = Character, Color}
                   Fa : Byte;
                 End;
      TCline  = Array[0..79] of TChr;
      TScreen = Array[0..24] of TCline;
      PScreen = ^TScreen;

Const BMPnum:Integer=-1;
      CXlat : Array[0..16] of Byte =
(0,  4,  2,  6,  1,  5,  3, 8,
 7,$0C,$0A,$0E,$09,$0D,$0B,$0F,8); {do not modify this, modify BMPXLAT instead}
      VidMode : Byte = 0;
      ScrPage : Byte = 0;
      LinesPC : Byte = 16;

Const BMPhead:Array[0..117] of Byte=
($42,$4D,$60,$04,$02,$00,0,0,0,0,$76,0,0,0,$28,0,
 0,0,$88,$02,0,0,$98,$01,0,0,$01,0,$04,0,0,0,
 0,0,0,0,0,0,0,0,0,0,0,0,0,0,$10,0,
 0,0,0,0,0,0,
 0,0,0,0,   {36H=54z = address of RGB palette}
 0,0,$B0,0,
 0,$A0,0,0,
 0,$40,$90,0,
 $A0,0,0,0,
 $80,0,$80,0,
 $80,$80,0,0,
 $60,$60,$60,0,
 $C0,$C0,$C0,0,
 0,0,$FF,0,
 0,$FF,0,0,
 0,$FF,$FF,0,
 $FF,0,0,0,
 $FF,0,$FF,0,
 $FF,$FF,0,0,
 $FF,$FF,$FF,0); {optimized? Palette, do not modify here, see at BMPXLAT}

Var   Screen  : PScreen ;
      ChrSet  : PCharSet;
      BMPpath : PathStr; {must be global}

Procedure MakeLFN(W : Word); {German: Laufende Nummer=counter}
Var I : Integer;
    S7 : String[7];
Begin
  Str(W:4,S7);
  for I := 1 to 3 do
    if S7[I]=' ' then S7[I] := '0';
  I := length(BMPpath)-7;
  Move(S7[1],BMPpath[I],4); {a little dirty?}
End;

Procedure Text2BMP16; {the writing procedure}
Var F : File;
    B  : Array[-2..321] of Byte;
    written,XC,YC,X,Y,XX : Integer;
    Bord,CL,FF,FB,GF,GB,Px : Byte;
    CW : TChr;
Begin
  MakeLFN(BMPnum);
  Inc(BMPnum); {for the next following screenshot}
  Assign(F,BMPpath);
{$I-} Rewrite(F,1); {$I+}
  if IOresult=0 then
    Begin
  Write(^G); {start beep, screenshot will take several seconds}
  BlockWrite(F,BMPhead,sizeof(BMPhead),written);
  Bord := CXlat[16]+CXlat[16] shl 4; {2 pixels / byte}
  Fillchar(B,sizeof(B),Bord);
  For Y := 3 downto 0 do
    BlockWrite(F,B,sizeof(B),written); {bottom border}
  For YC := 24 downto 0 do
    Begin
      for Y := 15 downto 0 do {bmp reads from bottom to top}
        Begin
          XX := 0;  {pixel-byte pointer}
          for XC := 0 to 79 do
            Begin
              CW := Screen^[YC][XC];  {german: Farbe=color, Buchstabe=character}
              CL := ChrSet^[CW.Bu][Y];          {char_line}
              FF := CXlat[CW.Fa and $0F];       {foregnd color}
              FB := CXlat[(CW.Fa shr 4) and 7]; {backgnd color, mask off blinking bit. Paper doesn't blink}
              GF := FF shl 4; GB := FB shl 4;   {prep for speed}
              for X := 0 to 3 do  {1 char = 4 pixel-pairs}
                Begin
                  if (CL and $40)=$40 then
                    Px := FF
                  else
                    Px := FB;
                  if (CL and $80)=$80 then {hi nibble}
                    Px := Px OR GF
                  else
                    Px := Px OR GB;
                  B[XX] := Px;    {write 2 pixels (16color) to BMP line}
                  Inc(XX);        {up til 319}
                  CL := CL shl 2; {shift pixels of char_line}
                End;
            End;
          BlockWrite(F,B,sizeof(B),written); {1 video line}
        End;
    End;
  Fillchar(B,sizeof(B),Bord);
  For Y := 3 downto 0 do
    BlockWrite(F,B,sizeof(B),written); {top border}
  Close(F);
  Write(^G); {beep}
    End; {if IOresult=0}
End;
 

{invoked from the main program on function-key}
Procedure Screen2BMP;
Begin
ASM
        PUSH    BP
        PUSH    DS
        MOV     AX,0F00H   {get video mode}
        INT     10H
        POP     DS
        MOV     VidMode,AL   {3 = CO80}
        AND     BH,3
        MOV     ScrPage,BH   {usually 0}
        PUSH    DS
        MOV     AX,1130H     {get charset}
        MOV     BX,0600H     { Int 43h = Cur CharSet, probably you prefer this? }
        INT     10H
        POP     DS
        MOV     WORD PTR ChrSet,  BP
        MOV     WORD PTR ChrSet+2,ES
        MOV     LinesPC,CL   {video lines per character: CGA=8, EGA=14, VGA/400=16}
        POP     BP
End;
  if (VidMode = 3) and (LinesPC=16) then {check for 80x25 VGA}
    Begin
      Screen := Ptr($B800,ScrPage*4096);
      Text2BMP16;
    End;
End;
 

{setup:
 * next SCRV####.BMP
 * read BMP-palette file}
Procedure InitText2BMP;
Var X,Y,I : Integer;
    FN,U  : PathStr;
    SR : SearchRec;
    T  : Text;
Begin
  BMPnum := 0;
  BMPpath := FExpand('SCRV????.BMP'); {you can modify the first 4 chars, but must be 4 chars}
  FindFirst(BMPpath,Archive or ReadOnly,SR);
  while DOSerror=0 do
    Begin
      FN := Copy(SR.Name,5,4);
      Val(FN,X,Y);
      if Y=0 then
        if X >= BMPnum then
          BMPnum := X+1; {detect highest #### of existing .BMP file}
      FindNext(SR);
    End;
{now read the color mapping definition file}
  Assign(T,'BMPXLAT.INI'); {first try actual CD workdir}
{$I-} Reset(T); {$I+}
  I := IOresult;
  if I=2 then {if not found then try load dir of .EXE}
    Begin
      FN := ParamStr(0);
      while (FN > '') and (FN[length(FN)] <> '\') do
        Dec(FN[0]); {clip 'applic.exe'}
      FN := FN+'BMPXLAT.INI';
      Assign(T,FN);
{$I-} Reset(T); {$I+}
      I := IOresult;
    End;
  if I=0 then
    Begin
      I := 0;
      Repeat
        ReadLn(T,FN);
        if FN > '' then
          Begin
            Val(FN,X,Y);
            if Y=0 then
              CXlat[I] := X;
          End;
        Inc(I);
      Until (I > 16) or EOF(T);
      I := 0;
      Readln(T,FN);
      if FN='PALETTE RGB' then
        Repeat
          ReadLn(T,FN);
          X := 0;
          Repeat  {read 3 numbers RGB per line}
            U := '';
            while (FN > '') and not (FN[1] in ['0'..'9']) do Delete(FN,1,1);
            Repeat
              U := U+FN[1];
              Delete(FN,1,1);
            Until (FN='') or not (FN[1] in ['0'..'9']);
            if U > '' then
              Val(U,BMPhead[54+4*I+X],Y);
            Inc(X);
          Until FN='';
          Inc(I);
        Until EOF(T) or (I > 15);
      Close(T);
    End
  else
    Begin
      Assign(T,'BMPXLAT.INI');
      Rewrite(T);    {if no xlat found, create new with default values}
      for I := 0 to 16 do
        Writeln(T,CXlat[I]);   {from default translation table}
      Writeln(T,'PALETTE RGB');
      for I := 0 to 15 do
        Begin
          for X := 0 to 2 do
            Begin
              Write(T,BMPhead[54+4*I+X]); {from default palette}
              if X < 2 then Write(T,',') else Write(T,^M^J);
            End;
        End;
      Writeln(T,'end of RGB palette.');
      Writeln(T,'>>>--SCR2BMP--> (c) 1997 MEG-Glaser A-4191'); {add explanation to ini-file}
      Writeln(T,'  fixed format:');
      Writeln(T,'lines 1...16: SCR {=CGA/EGA/VGA16} -> RGB translation list.');
      Writeln(T,'line 17: border color (RGB#).');
      Writeln(T,'line 18: "PALETTE RGB" key string.');
      Writeln(T,'lines 19..34: RGB Palette (### 0..15).');
      Writeln(T,'If SCR2BMP does not find this BMPXLAT.INI file in the CD directory or in the');
      Writeln(T,'load directory, it will create the file with default values.');
      Close(T);
    End;
End;

Begin
  InitText2BMP;
End.


This example source code is displayed for serious programmers only, who usually do their work themselves, not for those dynamic and smart guys who simply download ready made programs. These shall better write some "C" code, there are a lot more downloadable object files.

Example screenshots of the AAG program written with Turbo Vision in TP 6. The screenshot event must be catched in the GetEvent procedure to be effective when the help screen is displayed.
You can download the AAG demo version from my professional URL, yet it is in German.

Das AAG - Programm ist ein Chef-Programm für Handwerker und Kaufleute, zum "Anbahnen und Abwickeln von Geschäften".

example screenshot AAG help window
You will probably detect that the characters look somewhat bold on the screenshot. This comes from the fact that Scr2BMP writes a 640 pixel wide image, but the VGA textscreen uses 720 pixels horizontally, 9 pixels  per character. But this would lead to an irritating width/height aspect ratio in the BMP image.
example screenshot AAG window list

http://members.eunet.at/meg-glaser
 
 to the TP link-page

This page hosted by  Get your own Free Homepage