mmdib.pas

一套及时通讯的原码

const
  HFILE_ERROR = -1;
{$ENDIF}

(************************************************************************)
(* Open a DIB file and return a MEMORY DIB, a memory handle containing..*)
(************************************************************************)
function DIB_OpenFile(szFile: PChar): PDIB;
var
   fh: THandle;
   dwLen: DWORD;
   dwBits: DWORD;
   pd: PDIB;
   p: Pointer;
   ofs: TOFSTRUCT;
   h: THandle;

begin
   Result := nil;
   fh := OpenFile(szFile, ofs, OF_READ);

   if (fh = HFILE_ERROR) then
   begin
      h := FindResource(HInstance, szFile, RT_BITMAP);

      if (h <> 0) then
      begin
         {$IFDEF WIN32}
         { !!! can we call GlobalFree() on this? is it the right format. }
         { !!! can we write to this resource?                            }
         Result := PDIB(LockResource(LoadResource(HInstance, h)));
         exit;
         {$ELSE}
         fh := AccessResource(HInstance, h);
         {$ENDIF}
      end;
   end;

   if (fh = HFILE_ERROR) then exit;

   pd := DIB_ReadBitmapInfo(fh);
   if (pd = nil) then exit;

   { How much memory do we need to hold the DIB }
   dwBits := pd^.biSizeImage;
   dwLen  := pd^.biSize + DIB_PaletteSize(pd) + dwBits;

   { Can we get more memory? }
   p := GlobalReAllocPtr(pd,dwLen,0);
   if (p = nil) then
   begin
      GlobalFreePtr(pd);
      pd := Nil;
   end
   else pd := PDIB(p);

   if (pd <> nil) then
   begin
      { read in the bits }
      _hread(fh, PChar(pd) + pd^.biSize + DIB_PaletteSize(pd), dwBits);
   end;

   _lclose(fh);
   Result := pd;
end;

(************************************************************************)
(*  ReadDibBitmapInfo()                                                 *)
(*                                                                      *)
(*  Will read a file in DIB format and return a global HANDLE to its    *)
(*  BITMAPINFO.  This function will work with both "old" and "new"      *)
(*  bitmap formats, but will always return a "new" BITMAPINFO.          *)
(************************************************************************)
function DIB_ReadBitmapInfo(fh: THANDLE): PDIB;
type
    PRGBTRIPLE = ^RGBTRIPLE;
    RGBTRIPLE  = array[0..0] of TRGBTRIPLE;

    PRGBQUAD = ^RGBQUAD;
    RGBQUAD  = array[0..0] of TRGBQUAD;

var
   off: DWORD;
   size, i: integer;
   nNumColors: DWORD;
   pRGB: PRGBQUAD;
   RGB: TRGBQUAD;
   bi: TBITMAPINFOHEADER;
   bc: TBITMAPCOREHEADER;
   bf: TBITMAPFILEHEADER;
   pd: PDIB;

begin
   Result := nil;

   if (fh = HFILE_ERROR) then exit;

   off := _llseek(fh,0,SEEK_CUR);

   if (sizeof(bf) <> _lread(fh,@bf,sizeof(bf))) then exit;

   { do we have a RC HEADER? }
   if (bf.bfType <> BFT_BITMAP) then
   begin
      bf.bfOffBits := 0;
      _llseek(fh,off,SEEK_SET);
   end;

   if (sizeof(bi) <> _lread(fh,@bi,sizeof(bi))) then exit;

   { what type of bitmap info is this? }
   size := bi.biSize;
   if (size = sizeof(TBITMAPCOREHEADER)) then
   begin
      bc := PBITMAPCOREHEADER(@bi)^;
      bi.biSize          := sizeof(TBITMAPINFOHEADER);
      bi.biWidth         := bc.bcWidth;
      bi.biHeight        := bc.bcHeight;
      bi.biPlanes        := bc.bcPlanes;
      bi.biBitCount      := bc.bcBitCount;
      bi.biCompression   := BI_RGB;
      bi.biSizeImage     := 0;
      bi.biXPelsPerMeter := 0;
      bi.biYPelsPerMeter := 0;
      bi.biClrUsed       := 0;
      bi.biClrImportant  := 0;
      _llseek(fh,sizeof(TBITMAPCOREHEADER)-sizeof(TBITMAPINFOHEADER),SEEK_CUR);
   end;

   nNumColors := DIB_NumColors(@bi);

   FixBitmapInfo(@bi);

   pd := GlobalAllocMem(bi.biSize + nNumColors * sizeof(TRGBQUAD));

   if (pd = nil) then exit;

   pd^ := bi;

   pRgb := PRGBQUAD(DIB_Colors(pd));

   if (nNumColors > 0) then
   begin
      if (size = sizeof(TBITMAPCOREHEADER)) then
      begin
         { convert a old color table (3 byte entries) to a new }
         { color table (4 byte entries)                        }
         _lread(fh,PChar(pRgb),nNumColors * sizeof(TRGBTRIPLE));

         for i := nNumColors-1 downTo 0 do
         begin
            rgb.rgbRed      := PRGBTRIPLE(pRgb)^[i].rgbtRed;
            rgb.rgbBlue     := PRGBTRIPLE(pRgb)^[i].rgbtBlue;
            rgb.rgbGreen    := PRGBTRIPLE(pRgb)^[i].rgbtGreen;
            rgb.rgbReserved := 0;

            pRgb^[i] := rgb;
         end;
      end
      else _lread(fh,PChar(pRgb),nNumColors * sizeof(TRGBQUAD));
   end;

   if (bf.bfOffBits <> 0) then
      _llseek(fh,off + bf.bfOffBits,SEEK_SET);

   Result := pd;
end;

(************************************************************************)
(*  DibSetUsage(hdib,hpal,wUsage)                                       *)
(*                                                                      *)
(*  Modifies the color table of the passed DIB for use with the wUsage  *)
(*  parameter specifed.                                                 *)
(*                                                                      *)
(*  if wUsage is DIB_PAL_COLORS the DIB color table is set to 0-256     *)
(*  if wUsage is DIB_RGB_COLORS the DIB color table is set to the RGB   *)
(*  values in the passed palette                                        *)
(************************************************************************)
function DIB_SetUsage(pbi: PDIB; hPal: HPALETTE; wUsage: UINT): Boolean;
type
    PRGBQUAD = ^RGBQUAD;
    RGBQUAD  = array[0..0] of TRGBQUAD;

var
   ape: array[0..255] of TPALETTEENTRY;
   pRGB: PRGBQUAD;
   pw: PWord;
   nColors: Longint;
   i: integer;

begin
   Result := False;

   if (pbi = nil) then exit;

   if (hpal = 0) then
       hpal := GetStockObject(DEFAULT_PALETTE);

    nColors := DIB_NumColors(pbi);

    if (nColors = 3) and (DIB_Compression(pbi) = BI_BITFIELDS) then
        nColors := 0;

    if (nColors > 0) then
    begin
       pRgb := PRGBQUAD(DIB_Colors(pbi));

       case wUsage of
          DIB_PAL_COLORS:
          begin
             { Set the DIB color table to palette indexes }
             pw := Pointer(pRgb);
             for i := 0 to nColors-1 do
             begin
                pw^ := i;
                inc(pw);
             end;
          end;
          else
          begin
             { Set the DIB color table to RGBQUADS }
             { DIB_RGB_COLORS:                     }
             nColors := min(nColors,256);
             GetPaletteEntries(hpal,0,nColors,ape);
             for i := 0 to nColors-1 do
             begin
                pRgb^[i].rgbRed      := ape[i].peRed;
                pRgb^[i].rgbGreen    := ape[i].peGreen;
                pRgb^[i].rgbBlue     := ape[i].peBlue;
                pRgb^[i].rgbReserved := 0;
             end;
          end;
       end;
    end;
    Result := True;
end;

(************************************************************************)
(*  Dib_Create                                                          *)
(*                                                                      *)
(*  Creates a new packed DIB with the given dimensions and the          *)
(*  given number of bits per pixel                                      *)
(*                                                                      *)
(*  Orientation: -1 = TOP_DOWN, 1 = BOTTOM_UP                           *)
(************************************************************************)
function DIB_Create(Bits, Orientation, Width, Height: integer; AllocBits: Boolean): PDIB;
var
   pbi: PDIB;
   i: integer;
   pdw: PLongint;
   dwSizeImage: Longint;

begin
   Result := nil;
   width := Max(width,1);
   height := Max(height,1);
   if (Bits > 8) and (Bits <> 24) then Bits := 24;

   if AllocBits then
      dwSizeImage := WIDTHBYTES(Longint(Width)*Bits) * Height
   else
      dwSizeImage := 0;

   pbi := GlobalAllocMem(sizeof(TBITMAPINFOHEADER)+dwSizeImage+256*sizeOf(TRGBQuad));
   if (pbi = nil) then exit;

   pbi^.biSize          := sizeof(TBITMAPINFOHEADER);
   pbi^.biWidth         := Width;
   pbi^.biHeight        := Height * Orientation;
   pbi^.biPlanes        := 1;
   pbi^.biBitCount      := Bits;
   pbi^.biCompression   := BI_RGB;
   pbi^.biSizeImage     := dwSizeImage;
   pbi^.biXPelsPerMeter := 0;
   pbi^.biYPelsPerMeter := 0;
   pbi^.biClrUsed       := 0;
   pbi^.biClrImportant  := 0;

   if (bits = 4) then
       pbi^.biClrUsed := 16
   else if (bits = 8) then
       pbi^.biClrUsed := 256;

   pdw := PLongint(PChar(pbi)+pbi^.biSize);

   for i := 0 to (pbi^.biClrUsed div 16)-1 do
   begin
      pdw^ := $00000000;    { 0000  black          }
      inc(pdw);
      pdw^ := $00800000;    { 0001  dark red       }
      inc(pdw);
      pdw^ := $00008000;    { 0010  dark green     }
      inc(pdw);
      pdw^ := $00808000;    { 0011  mustard        }
      inc(pdw);
      pdw^ := $00000080;    { 0100  dark blue      }
      inc(pdw);
      pdw^ := $00800080;    { 0101  purple         }
      inc(pdw);
      pdw^ := $00008080;    { 0110  dark turquoise }
      inc(pdw);
      pdw^ := $00C0C0C0;    { 1000  gray           }
      inc(pdw);
      pdw^ := $00808080;    { 0111  dark gray      }
      inc(pdw);
      pdw^ := $00FF0000;    { 1001  red            }
      inc(pdw);
      pdw^ := $0000FF00;    { 1010  green          }
      inc(pdw);
      pdw^ := $00FFFF00;    { 1011  yellow         }
      inc(pdw);
      pdw^ := $000000FF;    { 1100  blue           }
      inc(pdw);
      pdw^ := $00FF00FF;    { 1101  pink (magenta) }
      inc(pdw);
      pdw^ := $0000FFFF;    { 1110  cyan           }
      inc(pdw);
      pdw^ := $00FFFFFF;    { 1111  white          }
   end;
   Result := pbi;
end;

(************************************************************************)
procedure xlatClut8(pb: PByte; dwSize: DWORD; xlat: PByteArray);
var
   dw: DWORD;

begin
   for dw := 0 to dwSize-1 do
   begin
      pb^ := xlat^[pb^];
      incHuge(pb,sizeOf(pB^));
   end;
end;

(************************************************************************)
procedure xlatClut4(pb: PByte; dwSize: DWORD; xlat: PByteArray);
var
   dw: DWORD;

begin
   for dw := 0 to dwSize-1 do
   begin
      pb^ := xlat^[pb^ and $0F] or (xlat^[(pb^ shr 4) and $0F] shl 4);
      incHuge(pb,sizeOf(pB^));
   end;
end;

(************************************************************************)
procedure xlatRle8(pb: PByte; dwSize: DWORD; xlat: PByteArray);
const
     RLE_ESCAPE = 0;
     RLE_EOL    = 0;
     RLE_EOF    = 1;
     RLE_JMP    = 2;
var
   b,cnt: Byte;
   prle: PByte;

begin
   prle := pb;

   while True do
   begin
      cnt := prle^;
      incHuge(prle,1);
      b   := prle^;

      if (cnt = RLE_ESCAPE) then
      begin
         incHuge(prle,1);

         case b of
            RLE_EOF: exit;
            RLE_EOL: ;

            RLE_JMP: incHuge(prle,2); { skip dX,dY }
            else
            begin
               cnt := b;
               for b := 0 to cnt-1 do
               begin
                  prle^ := xlat^[prle^];
                  incHuge(prle,1);
               end;
               if (cnt and 1 > 0) then incHuge(prle,1);
            end;
         end;
      end
      else
      begin
         prle^:= xlat^[b];
         incHuge(prle,1);
      end;
   end;
end;

(************************************************************************)
procedure xlatRle4(pb: PByte; dwSize: DWORD; xlat: PByteArray);
begin
end;

(************************************************************************)
(*  DibMapToPalette(pdib, hpal)                                         *)
(*                                                                      *)
(*  Map the colors of the DIB, using GetNearestPaletteIndex, to         *)