roboforum.ru

Смещение   Длина поля   Описание поля (что тут находится)
Заголовок файла
0   2   Код 4D42h - Буквы 'BM'
2   4   Размер файла в байтах
6   2   0 (Резервное поле)
8   2   0 (Резервное поле)
10   4   Смещение, с которого начинается само    изображение (растр).
Заголовок BITMAP (Информация об изображении)
14   4   Размер заголовка BITMAP (в байтах) равно 40
18   4   Ширина изображения в пикселях
22   4   Высота изображения в пикселях
26   2   Число плоскостей, должно быть 1
28   2   Бит/пиксел: 1, 4, 8 или 24
30   4   Тип сжатия
34   4   0 или размер сжатого изображения в байтах.
38   4   Горизонтальное разрешение, пиксел/м
42   4   Вертикальное разрешение, пиксел/м
46   4   Количество используемых цветов
50   4   Количество "важных" цветов.
Палитра (Карта цветов для N цветов), если используется
54   4*N   Палитра
Формат цвета
R8G8B8RESERVED8

Dim Color As Byte
Dim I As Integer
Dim K As Integer
Const Filename1 = "lb.bmp"

Open Filename1 For Binary As #4
Cls
Do
For I = -1 To 65 '-1 связано со смещением
   For K = -1 To 96 'сетки координат
      Get #4 , Color
      Pset K , I , Color 'pset X,Y, Color
   Next
Next
Loop Until Eof(#4) <> 0
Close #4

function convert(r: byte; g: byte; b: byte): byte;
begin
   result := r*r + g*g + b*b;
   result := sqrt(result/3)
   result := trunc(result);
end;

const
  filename = 'linux.bmp';
  fileout = 'output.bmp';
var
  i,k: byte;
  old: word;
  f, f2, f3: TFileStream;
  c: array[1..3] of byte;
  buf: byte;
  header: BITMAPFILEHEADER;
  info: BITMAPINFOHEADER;
  pos_palette: word;
  pos_data: word;
begin
  f := TFileStream.Create(filename, fmOpenRead);
  f.ReadBuffer(header, sizeof(header)); // читаю заголовки
  f.ReadBuffer(info, sizeof(info));
  pos_palette := f.Position;
  pos_data := header.bfOffBits;
  f.Position := pos_data; // устанавливаю указатель на данных
  // подготавливаю буффер файл для записи строк
  f2 := TFileStream.Create('buf', fmCreate); 
  for i := 0 to 66 do // для сименса будут другие значения
  begin
    for k := 0 to 97 do
    begin
      f.ReadBuffer(buf, 1);
      old := f.Position;
      f.Position := pos_palette + buf;    
      f.ReadBuffer(c, 3);   // считываю и преобразовываю цвет
      f2.WriteBuffer(convert(c[1],c[2],c[3]), 1);
      f.Position := old;
    end;
    f.Position := f.Position + 2;
  end;
  // разворачиваю строки
  f3 := TFileStream.Create(fileout, fmCreate);
  f2.Seek(-98, soFromEnd);
  for i := 0 to 66 do
  begin
    for k := 0 to 97 do
    begin
      f2.ReadBuffer(buf, 1);
      f3.WriteBuffer(buf, 1);
    end;
    f2.Seek(-196, soFromCurrent);
  end;        
end;

function color_encode(r: byte; g:byte; b:byte): byte;
var
  segment: byte;
  value: byte;
begin
  segment := 256 div 8;
  value := (r div segment) shl 5;
  result := value;
  value := (g div segment) shl 2;
  result := result or value;

  segment := 256 div 4;
  value := b div segment;
  result := result or value;
end;

function color_decode(color: byte): TColor;
var
  r,g,b: byte;
  segment: byte;
begin
  segment := 256 div 7;
  r := (color shr 5) * segment;
  g := ((color and $1C) shr 2) * segment;
  segment := 256 div 3;
  b := (color and $03) * segment;
  result := RGB(r,g,b);
end;

  for i := 0 to 66 do
    for k := 0 to 97 do with bmp_preview.Canvas do  // bmp_preview - TImage class
    begin
      col := ColorToRGB(Pixels[k,i]); // any 24 or more bits variable
      buf := color_encode(col, col shr 8, col shr 16);
      file_out.WriteBuffer(buf, 1);  // file_out - TFileStream class
    end;

Dim Color As Byte
Dim I As Integer
Dim K As Integer
Const Filename1 = "lb.mbi"

Open Filename1 For Binary As #4
Cls
Do
For I = -1 To 65 '-1 связано со смещением
   For K = -1 To 96 'сетки координат
      Get #4 , Color
      Pset K , I , Color 'pset X,Y, Color
   Next
Next
Loop Until Eof(#4) <> 0
Close #4