Source file: /~heha/hs/dos/dosmisc.zip/SRC/PIC2BMP.PAS

{$A+,B-,D-,E-,F-,G-,I-,L-,N-,O-,P+,Q-,R-,S-,T+,V+,X+}
{$M $1000,$1000,$20000}
program pic2bmp;
{wandelt Turbo Pascals GetImage-Speicherabzüge (nur 16-Farben-VGA-Modi)
 in Windows-Bitmaps}
uses WinDos,Strings,WinTypes;

function GetNibble(p:PByte;bitno,xx:Integer):Byte;
 var
  i: Integer;
  b: Byte;
 begin
  b:=0;
  for i:=0 to 3 do begin
   b:=b or ((p^ shr bitno) and 1) shl i;
   Inc(p,xx);
  end;
  GetNibble:=b;
 end;

procedure Transform(p,q:PByte; x,y:Integer);
{Wandelt vier-ebenen-orientiertes Bitmap <p> in Byte-Zeilenausrichtung
 in nibble-orientiertes, gestürztes Pixmap <q> in DWORD-Zeilenausrichtung um.
 x und y sind die Ausdehnungen von Quelle und Ziel.
 Bei q muss genügend ausgenullter Speicher vorhanden sein!}
 var
  pp,qq:PByte;
  xx,xp,xq,bit:Integer;
  b: Byte;
 begin
  xp:=(x+7)shr 3;	{Bytes pro Scanzeile und Ebene im .PIC}
  xq:=xp shl 2;		{Bytes pro Scanzeile im .BMP}
  Inc(q,xq*y);		{ans Ende}
  for y:=y-1 downto 0 do begin
   Dec(q,xq);
   pp:=p;
   qq:=q;
   for xx:=0 to x-1 do begin
    bit:=not xx and 7;
    b:=GetNibble(pp,bit,xp);
    if not Odd(xx) then b:=b shl 4;
    qq^:=qq^ or b;
    if Odd(xx) then Inc(qq);
    if bit=0 then Inc(pp);
   end;
   Inc(p,xq);
  end;
 end;

var
 filename: array[0..79] of Char;
 fsize: Word;	{länger als WORD geht's nicht}
 f: file;
 sp: PChar;
 p,q: PByte;
type
 TBmpHdr=record
  fh: TBitmapFileHeader;
  ih: TBitmapInfoHeader;
  co: array[0..15] of LongInt;
 end;
 LongRec=record
  lo,hi:Integer;
 end;
const
 BmpHdr:TBmpHdr=(
  fh:(bfType:$4D42;
      bfSize: sizeof(TBmpHdr);	{<-ändern!}
      bfReserved1: 0;
      bfReserved2: 0;
      bfOffBits: sizeof(TBmpHdr));
  ih:(biSize: sizeof(TBitmapInfoHeader);
      biWidth:0;		{<-ändern!}
      biHeight:0;		{<-ändern!}
      biPlanes:1;
      biBitCount:4;
      biCompression:0;
      biSizeImage:0;		{<-ändern!}
      biXPelsPerMeter:2835;	{72 dpi}
      biYPelsPerMeter:2835;
      biClrUsed:0;
      biClrImportant:0);
  co:($000000,$800000,$008000,$808000,$000080,$800080,$008080,$808080,
      $C0C0C0,$FF0000,$00FF00,$FFFF00,$0000F0,$FF00FF,$00FFFF,$FFFFFF));
var
 x,y,xy:Word;		{xy = Größe der .BMP-Pixeldaten}
 b: Byte;
 qqq: PByte;

begin
 FileMode:=0;
 if GetArgCount<>1 then begin
  WriteLn(
'Wandelt Turbos GetImage-Speicherabzug (nur 16-Farben-VGA) in Windows-BMP.'#13#10+
' Natürlich nur mit Standard-Farbpalette; Falschfarben sind möglich!  h#s 09/02'#13#10+
'Quell-Dateiname angeben!');
  exit;
 end;
 GetArgStr(filename,1,sizeof(filename));
 Assign(f,filename); Reset(f,1);
 if IOResult<>0 then begin
  WriteLn('Konnte Datei ',filename,' nicht öffnen.');
  exit;
 end;
 if FileSize(f)>$FFE0 then begin
  WriteLn('Datei zu groß! Als Speicherabzug unwahrscheinlich!');
  exit;
 end;
 fsize:=FileSize(f);
 GetMem(p,fsize);
 BlockRead(f,p^,fsize);
 Close(f);

 x:=PPoint(p)^.x;
 y:=PPoint(p)^.y;
 Write('GetImage-Dimensionen von ',filename,': x=',x,', y=',y);
 if (x>1024) or (y>1024) then begin
  WriteLn(#13#10' Dimensionen unwirklich! Wohl kein GetImage-Speicherabzug?');
  exit;
 end;
 xy:=(((x+7)shr 3)shl 2)*y;
 if xy+4>fsize then begin
  WriteLn(#13#10' Quelldatei zu kurz!');
  exit;
 end;
 Inc(LongRec(BmpHdr.fh.bfSize).lo,xy);
 LongRec(BmpHdr.ih.biWidth).lo:=x;
 LongRec(BmpHdr.ih.biHeight).lo:=y;
 LongRec(BmpHdr.ih.biSizeImage).lo:=xy;
 GetMem(q,xy);
 FillChar(q^,xy,0);
 Transform(PByte(PChar(p)+4),q,x,y);
 FreeMem(p,fsize);

 sp:=StrRScan(filename,'.');
 if sp=nil then sp:=StrEnd(filename);
 StrCopy(sp,'.BMP');
 Assign(f,filename); Rewrite(f,1);
 if IOResult<>0 then begin
  WriteLn(#13#10' Konnte Datei ',filename,' nicht erzeugen.');
  exit;
 end;
 BlockWrite(f,BmpHdr,sizeof(BmpHdr));	{komplett mit Farbtabelle}
 BlockWrite(f,q^,xy);			{alle Pixel auf einem Streich}
 Close(f);
 if IOResult=0 then WriteLn(' OK')
 else WriteLn(' Schreibfehler!');
 FreeMem(q,xy);
end.