Program BMP_Creator;
{$D+,E-,N+,G+}
const
  BfSize = 32768;
var
  f : Text;
  ftmp, fr, fh : file;
  S : Char;
  S1 : String;
  Src, Dst : String;
  fname, fresname : String;
  Red, Green, Blue : String;
  inTag : Boolean;
  i, j, Lng : Integer;
  Bl, Grn, Rd, Code : Integer;
  SizeX, SizeY, CntPix, FSize : Longint;
  Rot : array[1..3] of Byte;
  ColCnt : Byte;
  CurCol : Byte;
  Buff : array[0..BfSize-1] of Byte;
const
  tmpname = 'bmpcr.tmp';
  fheadname = 'bmphead.tmp';
Function HowMBits( b : Byte ) : Byte;
var
  i, c : Byte;
begin
  c := 0;
  for i := 0 to 7 do
    c := (b shr i) and 1 + c;
  HowMBits := c
end;
Function HexB(b : Byte) : String;
const
  HD: array[0..15] of Char = ('0','1','2','3','4','5','6','7',
  '8','9','A','B','C','D','E','F');
begin
  HexB := HD[b shr 4] + HD[b and $F]
end;
Function UpString(Sra : String) : String;
var
 i : Byte;
 Sr : String;
begin
  Sr := Sra;
  for i := 1 to Length(Sr) do
    Sr[i] := UpCase(Sr[i]);
  UpString := Sr
end;
begin
  Randomize;
  SizeX := 0;
  SizeY := 0;
  CntPix := 0;
  inTag := False;
  if ParamCount<2 then
  begin
    WriteLn;
    WriteLn('Нужны следующие параметры для работы программы :');
    WriteLn('bmpcr infile outfile');
    Halt;
  end;
  fname := ParamStr(1);
  fresname := ParamStr(2);
  WriteLn('Обрабатывается файл '+fname+'>>'+fresname);
  Assign(f, fname);
  Assign(fr, fresname);
  Assign(fh, fheadname);
  Assign(ftmp, tmpName);
  Reset(f);
  ReWrite(ftmp, 1);
  Repeat
   ReadLn(f, S1)
  Until (Upstring(S1)='
') or EOF(f);
  Red := '$00';
  Green := '$00';
  Blue := '$00';
  While not EOF(f) do
  begin
    Read(f, S);
    if S=#$0D then
    begin
     if SizeY = 0 then SizeX := CntPix;
     inc(SizeY);
     Continue;
    end;
    if S=#$0A then Continue;
    if S = '<' then inTag := True;
    if not inTag then
    begin
     BlockWrite(ftmp, Rd, 1);
     BlockWrite(ftmp, Grn, 1);
     BlockWrite(ftmp, Bl, 1);
     inc(CntPix);
    end;
    if inTag then if (S='=') then
    begin
        Read(f, Red[2]);
        Read(f, Red[3]);
        Read(f, Green[2]);
        Read(f, Green[3]);
        Read(f, Blue[2]);
        Read(f, Blue[3]);
        Val(Red, Rd, Code);
        Val(Green, Grn, Code);
        Val(Blue, Bl, Code);
    end;
    if inTag then if (UpCase(S)='P') then Break;
    if S = '>' then inTag := False;
  end;
  Close(ftmp);
  Close(f);
  ReWrite(fh, 1);
  S := 'B';
  BlockWrite(fh, S, 1);
  S := 'M';
  BlockWrite(fh, S, 1);
  FSize := SizeX*SizeY*3 + 54;
  BlockWrite(fh, FSize, 4);
  CntPix := 0;
  BlockWrite(fh, CntPix, 4);
  CntPix := 54;
  BlockWrite(fh, CntPix, 4);
  CntPix := $28;
  BlockWrite(fh, CntPix, 4);
  CntPix := SizeX;
  BlockWrite(fh, CntPix, 4);
  CntPix := SizeY;
  BlockWrite(fh, CntPix, 4);
  CntPix := 1;
  BlockWrite(fh, CntPix, 2);
  CntPix := $18;
  BlockWrite(fh, CntPix, 4);
{  FSize := FSize - 54;
  BlockWrite(fh, FSize, 4);}
  CntPix := 0;
  BlockWrite(fh, CntPix, 4);
  BlockWrite(fh, CntPix, 4);
  BlockWrite(fh, CntPix, 4);
  BlockWrite(fh, CntPix, 4);
  BlockWrite(fh, CntPix, 4);
  BlockWrite(fh, CntPix, 2);
  Close(fh);

  ReWrite(fr, 1);
  Reset(fh, 1);
  BlockRead(fh, Buff, 54);
  BlockWrite(fr, Buff, 54);
  Close(fh);
  Erase(fh);
  Reset(ftmp, 1);
  FSize := FileSize(ftmp);
  Seek(ftmp, 0);
  for i := 1 to FSize div BfSize do
  begin
    BlockRead(ftmp, Buff, BfSize);
    BlockWrite(fr, Buff, BfSize);
  end;
  BlockRead(ftmp, Buff, FSize mod BfSize);
  BlockWrite(fr, Buff, FSize mod BfSize);
  Close(ftmp);
  Close(fr);
  Erase(ftmp);
end.

Назад