langs a-z

Task/Bitmap/Pascal/bitmap.pascal

@@ -0,0 +1,131 @@
+Interface
+uses  crt,   { GetDir }
+      graph; { function GetPixel }
+
+type { integer numbers }
+  { from unit bitmaps XPERT software production Tamer Fakhoury }
+  _bit     = $00000000..$00000001; {number 1 bit   without sign = (0..1) }
+  _byte    = $00000000..$000000FF; {number 1 byte  without sign = (0..255)}
+  _word    = $00000000..$0000FFFF; {number 2 bytes without sign = (0..65 535)}
+  _dWord   = $00000000..$7FFFFFFF; {number 4 bytes without sign = (0..4 294 967 296)}
+  _longInt = $80000000..$7FFFFFFF; {number 4 bytes with sign
+                                    = (-2 147 483 648..2 147 483 648}
+
+  TbmpFileHeader =
+  record
+    ID: _word;             { Must be 'BM' =19778=$424D for windows }
+    FileSize: _dWord;      { Size of this file in bytes }
+    Reserved: _dWord;      { ??? }
+    bmpDataOffset: _dword; { = 54 = $36 from begining of file to begining of bmp data }
+  end;
+
+  TbmpInfoHeader =
+  record
+    InfoHeaderSize: _dword;      { Size of Info header
+                                   = 28h = 40 (decimal)
+                                   for windows }
+    Width,
+    Height: _longInt;    { Width and Height of image in pixels }
+    Planes,              { number of planes of bitmap }
+    BitsPerPixel: _word; { Bits can be 1, 4, 8, 24 or 32 }
+    Compression,
+    bmpDataSize: _dword;    { in bytes rounded to the next 4 byte boundary }
+    XPixPerMeter,           { horizontal resolution in pixels }
+    YPixPerMeter: _longInt; { vertical }
+    NumbColorsUsed,
+    NumbImportantColors: _dword;   {= NumbColorUsed}
+  end; { TbmpHeader = Record ... }
+
+  T32Color =
+  record { 4 byte = 32 bit }
+    Blue:  byte;
+    Green: byte;
+    Red:   byte;
+    Alfa:  byte
+  end;
+
+var directory,
+    bmpFileName:    string;
+    bmpFile:        file; { untyped file }
+    bmpFileHeader:  TbmpFileHeader;
+    bmpInfoHeader:  TbmpInfoHeader;
+    color32:        T32Color;
+    RowSizeInBytes: integer;
+    BytesPerPixel:  integer;
+
+const defaultBmpFileName = 'test';
+      DefaultDirectory   = 'c:\bp\';
+      DefaultExtension   = '.bmp';
+      bmpFileHeaderSize  = 14;
+      { compression specyfication }
+      bi_RGB             = 0;  { compression }
+      bi_RLE8            = 1;
+      bi_RLE4            = 2;
+      bi_BITFIELDS       = 3;
+
+      bmp_OK          = 0;
+      bmp_NotBMP      = 1;
+      bmp_OpenError   = 2;
+      bmp_ReadError   = 3;
+
+Procedure CreateBmpFile32(directory: string; FileName: string;
+                           iWidth, iHeight: _LongInt);
+
+{************************************************}
+Implementation  {-----------------------------}
+{************************************************}
+
+Procedure CreateBmpFile32(directory: string; FileName: string;
+                           iWidth, iHeight: _LongInt);
+  var
+    x, y: integer;
+  begin
+    if directory = '' then
+      GetDir(0, directory);
+    if FileName = '' then
+      FileName: = DefaultBmpFileName;
+    { create a new file on a disk in a given directory with given name }
+    Assign(bmpFile, directory + FileName + DefaultExtension);
+    ReWrite(bmpFile, 1);
+
+    { fill the headers }
+    with bmpInfoHeader, bmpFileHeader do
+    begin
+      ID := 19778;
+      InfoheaderSize := 40;
+      width := iWidth;
+      height := iHeight;
+      BitsPerPixel := 32;
+      BytesPerPixel := BitsPerPixel div 8;
+      reserved := 0;
+      bmpDataOffset := InfoHeaderSize + bmpFileHeaderSize;
+      planes := 1;
+      compression := bi_RGB;
+      XPixPerMeter := 0;
+      YPixPerMeter := 0;
+      NumbColorsUsed := 0;
+      NumbImportantColors := 0;
+
+      RowSizeInBytes := (Width * BytesPerPixel); { only for >=8 bits per pixel }
+      bmpDataSize := height * RowSizeinBytes;
+      FileSize := InfoHeaderSize + bmpFileHeaderSize + bmpDataSize;
+
+      { copy headers to disk file }
+      BlockWrite(bmpFile, bmpFileHeader, bmpFileHeaderSize);
+      BlockWrite(bmpFile, bmpInfoHeader, infoHeaderSize);
+
+      { fill the pixel data area }
+      for y := (height - 1) downto 0  do
+      begin
+	for x := 0 to (width - 1) do
+	begin { Pixel(x,y) }
+	  color32.Blue  := 255;
+	  color32.Green := 0;
+	  color32.Red   := 0;
+	  color32.Alfa  := 0;
+	  BlockWrite(bmpFile, color32, 4);
+	end; { for x ... }
+      end; { for y ... }
+      Close(bmpFile);
+    end; { with bmpInfoHeader, bmpFileHeader }
+   end; { procedure }