Procedures to save the 640 x 480 x 16 graphic screen to a Windows compatible .BMP file. Two versions are included, for 16 color BMP and a translated-to-gray-scale version. For 80x25 textscreens see Text2BMP.

The procedures shall be included in a unit of a graphical application program and be invoked with some function key to dump the screen to BMP files.

It is mainly used to make MANUALS or advertisements of a graphical program with a usual Windows program. Any count of files with subsequent #### are created whenever it is invoked. A color map file is used, and at the first run a virgin BMPXLAT.INI will be generated which may be edited on demand.

The program automatically creates .BMP files with increasing #### in the file name.

Fullport and SetViewPort() are included here, they must be defined elsewhere, if clipping is used in the main program.

----------------------------------------------------------
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);
      MXlat : Array[0..16] of Byte =
(0,16,32,48,64,80,96,112,
 8,16*9,16*10,16*11,16*12,16*13,16*14,255,128); {default xlat}

Procedure InitGraf2BMP;  {Shall be called in the unit's begin .. end.}
Var X,Y,I : Integer;
    FN  : PathStr;
    SR : SearchRec;
    T  : Text;
Begin
  BMPnum := 0;
  FindFirst('SCRX????.BMP',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;
      FindNext(SR);
    End;
  Assign(T,'BMPXLAT.INI'); {in the actual CD}
{$I-} Reset(T); {$I+}
  if IOresult=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;
      if not EOF(T) then
      Repeat
        ReadLn(T,FN);
        if FN > '' then
          Begin
            Val(FN,X,Y);
            if Y=0 then
              MXlat[I] := X;
          End;
        Inc(I);
      Until (I > 16) or EOF(T);
      Close(T);
    End
  else
    Begin
      Assign(T,'BMPXLAT.INI');
      Rewrite(T);
      for I := 0 to 16 do {0..15=black..white, 16=border}
        Writeln(T,CXlat[I]);
      for I := 0 to 16 do
        Writeln(T,MXlat[I]);
      Writeln(T,'... das ist die šbersetzungstabelle f?r die 16 Farben+BorderColor (Write .BMP)');
      Writeln(T,'... translation table for the 16 colors + BorderColor (Write .BMP)');
      Close(T);
    End;
End;

(* The following 2 procedures assume that 640x480x16 VGA graph
   is initialized and a picture is visible *)

Procedure GrafToBMP16;  {16 color BMP}

Const BMPhead:Array[0..117] of Byte=
($42,$4D,$16,$6A,$02,$00,0,0,0,0,$76,0,0,0,$28,0,
 0,0,$88,$02,0,0,$E8,$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,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); {optimierte/optimized Palette}

Var written,X,Y : Integer;
    F : File;
    FN : PathStr;
    Bord : Byte;
    B  : Array[-2..321] of Byte;
Begin
  Str(BMPnum:4,FN);
  for X := 1 to 3 do
    if FN[X]=' ' then
      FN[X] := '0'; {fill blanks -> '0'}
  Inc(BMPnum);
  Write(^G);
  FN := 'SCRX'+FN; {you may modify 'SCRX' here and on the other locs}
  FN := FN+'.BMP';
  Assign(F,FN);
  Rewrite(F,1);
  BlockWrite(F,BMPhead,sizeof(BMPhead),written);
  Fullport;
  Bord := CXlat[16]+CXlat[16] shl 4;
  Fillchar(B,sizeof(B),Bord);
  For Y := 3 downto 0 do
    BlockWrite(F,B,sizeof(B),written);
  For Y := 479 downto 0 do
    Begin
      for X := 0 to 319 do
        Begin
          B[X] := CXlat[GetPixel(X*2+1,Y)] OR CXlat[GetPixel(X*2,Y)] shl 4 ; {Farb-Byte}
        End;
      BlockWrite(F,B,sizeof(B),written);
    End;
  Fillchar(B,sizeof(B),Bord);
  For Y := 3 downto 0 do
    BlockWrite(F,B,sizeof(B),written);
  Close(F);
  SetViewPort(1,YTopBorder,MaxX-1,MaxY-14,ClipOn); {as used in the app program}
  Write(^G);
End;

{convert to mono .BMP}
Procedure GrafToBMPmo;
Const BMPhead:Array[0..$35] of Byte=
($42,$4D,$76,$D7,$04,$00,$00,$00,$00,$00,$36,$04,$00,$00,$28,$00,
 $00,$00,$88,$02,$00,$00,$E8,$01,$00,$00,$01,$00,$08,$00,$00,$00,
 $00,$00,$40,$D3,$04,$00,$00,$00,$00,$00,$00,$00,$00,$00,$00,$01,
 $00,$00,$00,$01,$00,$00);
Var written,X,Y : Integer;
    F : File;
    FN : PathStr;
    Bord : Byte;
    B  : Array[-4..643] of Byte;
    C  : Array[0..3] of Byte;
Begin
  Str(BMPnum:4,FN);
  for X := 1 to 3 do
    if FN[X]=' ' then
      FN[X] := '0';
  Inc(BMPnum);
  Write(^G);
  FN := 'SCRX'+FN;
  FN := FN+'.BMP';
  Assign(F,FN);
  Rewrite(F,1);
  BlockWrite(F,BMPhead,sizeof(BMPhead),written);
  fillchar(C,sizeof(C),#0);
  for X := 0 to 255 do
    Begin
      fillchar(C,3,$FF and X);
      BlockWrite(F,C,sizeof(C),written);
    End;
  Fullport;
  Bord := MXlat[16];
  Fillchar(B,sizeof(B),Bord);
  For Y := 3 downto 0 do
    BlockWrite(F,B,sizeof(B),written);
  For Y := 479 downto 0 do
    Begin
      for X := 0 to 639 do
        Begin
          B[X] := MXlat[GetPixel(X,Y)];
        End;
      BlockWrite(F,B,sizeof(B),written);
    End;
  Fillchar(B,sizeof(B),Bord);
  For Y := 3 downto 0 do
    BlockWrite(F,B,sizeof(B),written);
  Close(F);
  SetViewPort(1,YTopBorder,MaxX-1,MaxY-14,ClipOn);
  Write(^G);
End;
-----------
 

Mit diesen Routinen habe ich die Bilder gemacht, die Sie in meiner Homepage unter MEG-Graph sehen.

Look at my URL in the MEG-Graph subpage. The .GIF have been edited a little with Corel PhotoPaint to make the .GIF smaller.

Franz Glaser, Austria,   meg-glaser@eunet.at
http://members.eunet.at/meg-glaser
MEG-Graph process visualisation