mmdib.pas

一套及时通讯的原码

(*  the colors of the given palette.                                    *)
(************************************************************************)
procedure DIB_MapToPalette(var pbi: PDIB; hpal: HPALETTE);
type
    PRGBQUAD = ^RGBQUAD;
    RGBQUAD  = array[0..0] of TRGBQUAD;
var
   pe: TPALETTEENTRY;
   i: integer;
   nDibColors: DWORD;
   nPalColors: DWORD;
   lpBits,p: PByte;
   pRGB: PRGBQUAD;
   xlat: array[0..255] of Byte;
   SizeImage: DWORD;

begin
   nPalColors := 0;

   if (hpal = 0) or (pbi = nil) then exit;

   pRgb := PRGBQUAD(DIB_Colors(pbi));

   GetObject(hpal,sizeof(Word),@nPalColors);
   nDibColors := DIB_NumColors(pbi);

   SizeImage := pbi^.biSizeImage;
   if (SizeImage = 0) then
       SizeImage := DIB_SizeImage(pbi);

   { build a xlat table. from the current DIB colors to the given }
   { palette.                                                     }
   for i := 0 to nDibColors-1 do
       xlat[i] := GetNearestPaletteIndex(hpal,RGB(pRgb^[i].rgbRed,pRgb^[i].rgbGreen,pRgb^[i].rgbBlue));

   lpBits := DIB_Ptr(pbi);
   pbi^.biClrUsed := nPalColors;

   { re-size the DIB }
   if (nPalColors > nDibColors) then
   begin
      GlobalReAllocPtr(pbi, pbi^.biSize + nPalColors*sizeof(TRGBQUAD) + SizeImage, 0);
      p := DIB_Ptr(pbi);
      GlobalMoveMem(lpBits^, p^, SizeImage);
      lpBits := DIB_Ptr(pbi);
   end
   else if (nPalColors < nDibColors) then
   begin
      p := DIB_Ptr(pbi);
      GlobalMoveMem(lpBits^, p^, SizeImage);
      GlobalReAllocPtr(pbi, pbi^.biSize + nPalColors*sizeof(TRGBQUAD) + SizeImage, 0);
      lpBits := DIB_Ptr(pbi);
   end;

   { translate the DIB bits }
   case pbi^.biCompression of
       BI_RLE8: xlatRle8(lpBits, SizeImage, @xlat);
       BI_RLE4: xlatRle4(lpBits, SizeImage, @xlat);
       BI_RGB:
       begin
          if (pbi^.biBitCount = 8) then
              xlatClut8(lpBits, SizeImage, @xlat)
          else
              xlatClut4(lpBits, SizeImage, @xlat);
       end;
   end;

   { Now copy the RGBs in the logical palette to the dib color table }
   for i := 0 to nPalColors-1 do
   begin
      GetPaletteEntries(hpal,i,1,pe);
      pRgb^[i].rgbRed      := pe.peRed;
      pRgb^[i].rgbGreen    := pe.peGreen;
      pRgb^[i].rgbBlue     := pe.peBlue;
      pRgb^[i].rgbReserved := 0;
   end;
end;

(************************************************************************)
function DIB_CreatePalette(pbi: PDIB): HPALETTE;
var
  R,G,B: Byte;
  DstPal: PLogPalette;
  Colors: integer;
  DC: HDC;
  Focus: HWND;
  SysPalSize: Integer;
  Size: Longint;
  i: Integer;

begin
   Result := 0;

   Colors := DIB_NumColors(pbi);
   if Colors <> 0 then
   begin
      Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
      DstPal := GlobalAllocMem(Size);
      try
         with DstPal^ do
         begin
            palNumEntries := Colors;
            palVersion := $300;
            Focus := GetFocus;
            DC := GetDC(Focus);
            try
               SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
               if (Colors = 16) and (SysPalSize >= 16) then
               begin
                  { Ignore the disk image of the palette for 16 color }
                  { bitmaps use instead the first 8 and last 8 of the }
                  { current system palette                            }
                  GetSystemPaletteEntries(DC, 0, 8, palPalEntry);
                  i := 8;
                  GetSystemPaletteEntries(DC, SysPalSize - i, i, palPalEntry[i]);
               end
               else
               for i := 0 to Colors-1 do
               with palPalEntry[i] do
               begin
                  { Copy the palette for all others (i.e. 256 colors) }
                  peRed := PBitmapInfo(pbi)^.bmiColors[i].rgbRed;
                  peGreen := PBitmapInfo(pbi)^.bmiColors[i].rgbGreen;
                  peBlue := PBitmapInfo(pbi)^.bmiColors[i].rgbBlue;
                  peFlags := 0;
               end;

            finally
               ReleaseDC(Focus, DC);
            end;
         end;
         Result := CreatePalette(DstPal^);

      finally
         GlobalFreePtr(DstPal);
      end;
   end
   else if DIB_BitCount(pbi) = 24 then
   begin
      Colors:= 256;
      Size:= SizeOf(TLogPalette) + (Colors-1) * SizeOf(TPaletteEntry);
      DstPal := GlobalAllocMem(Size);
      try
         with DstPal^ do
         begin
            palVersion:= $300;
            palNumEntries:= Colors;
            R:= 0;
            G:= 0;
            B:= 0;
            for i := 0 to Colors-1 do
            with palPalEntry[i] do
            begin
               peRed:= R;
               peGreen:= G;
               peBlue:= B;
               peFlags:= 0;

               Inc(R, 32);
               if (R = 0) then
               begin
                  Inc(G, 32);
                  if (G = 0) then Inc(B, 64);
               end;
            end;
         end;
         Result:= CreatePalette(DstPal^);

      finally
         GlobalFreePtr(DstPal);
      end;
   end;
end;

(************************************************************************)
procedure DIB_Display(pbi: PDIB; DC: HDC; aRect: TRect);
var
   OldPal,Pal: HPalette;

begin
   OldPal := 0;
   Pal := DIB_CreatePalette(pbi);

   if Pal <> 0 then
   begin
      OldPal := SelectPalette(DC, Pal, False);
      RealizePalette(DC);
   end;

   SetStretchBltMode(DC, STRETCH_DELETESCANS);
   StretchDIBits(DC, aRect.Left,aRect.Top,
                     aRect.Right-aRect.Left, aRect.Bottom-aRect.Top,
                     0, 0, DIB_WIDTH(pBi), DIB_Height(pBi),
                     DIB_PTR(pbi), PBitmapInfo(pbI)^,
                     DIB_RGB_COLORS, SRCCOPY);

   if (OldPal <> 0) then
   begin
      SelectPalette(DC, OldPal, False);
      DeleteObject(Pal);
   end;
end;

(************************************************************************)
function DIB_BitmapToDIB(Handle: HBitmap; Palette: HPalette;
                         Bits, Orientation: integer): PDIB;
var
   lpbi: PDIB;
   lpBits: PByte;
   BM: TBitmap;
   OldPal: HPALETTE;
   DC: HDC;
   Focus: HWND;

begin
   Result := nil;
   GetObject(Handle, sizeOf(TBitmap), @BM);

   lpbi := DIB_Create(Bits, Orientation, BM.bmWidth, BM.bmHeight, True);
   if (lpbi <> nil) then
   with lpbi^ do
   begin
      OldPal := 0;
      Focus := GetFocus;
      DC := GetDC(Focus);
      try
         if Palette <> 0 then
         begin
            OldPal := SelectPalette(DC, Palette, False);
            RealizePalette(DC);
         end;
         lpBits := DIB_PTR(lpbi);
         if GetDIBits(DC, Handle, 0, BM.bmHeight, lpBits, PBitmapInfo(lpbi)^, DIB_RGB_COLORS) = 0 then
            DIB_Free(lpbi)
         else
            Result := lpbi;
      finally
         if (OldPal <> 0) then SelectPalette(DC, OldPal, False);
         ReleaseDC(Focus,DC);
      end;
   end;
end;

(************************************************************************)
procedure DIB_DIBToBitmap(pbi: PDIB; var Bitmap: HBitmap; var Pal: HPalette);
var
  Focus: HWND;
  DC: HDC;
  OldPal: HPALETTE;

begin
   OldPal := 0;
   { we use the handle of the window with the focus (which, if this }
   { routine is called from a menu command, will be this window) in }
   { order to guarantee that the realized palette will have first   }
   { priority on the system palette                                 }
   Focus := GetFocus;
   DC := GetDC(Focus);
   try
      Pal := DIB_CreatePalette(pbi);
      if Pal <> 0 then
      begin
         OldPal := SelectPalette(DC, Pal, False);
         RealizePalette(DC);
      end;

      Bitmap := CreateDIBitmap(DC, pbi^,  CBM_INIT, DIB_PTR(pbi),
                               PBitmapInfo(pbi)^, DIB_RGB_COLORS);
   finally
      if (OldPal <> 0) then SelectPalette(DC, OldPal, False);
      ReleaseDC(Focus, DC);
   end;
end;

(************************************************************************)
function LoadPalette(FName: string): PLOGPALETTE;
Label ERROR_OPEN;
var
   {$IFDEF WIN32}
   hmio   : HMMIO;
   {$ELSE}
   hmio   : THMMIO;
   {$ENDIF}
   ckFile : TMMCKINFO;
   ckChunk: TMMCKINFO;
   iSize  : integer;
   iColors: integer;
   pData  : Pointer;
   pLogPal: PLOGPALETTE;
   aBuf   : array[0..MAX_PATH] of Char;

begin
   Result := nil;
   hmio   := 0;
   pData  := nil;
   if (FName <> '') then
   begin
      StrPCopy(aBuf,FName);
      hmio := mmioOpen(aBuf, nil, MMIO_READ OR MMIO_ALLOCBUF);
      if (hmio = 0) then
          goto ERROR_OPEN;

      { Check it's a RIFF PAL file }
      ckFile.fccType := $204C4150; {'P','A','L',' '};
      if (mmioDescend(hmio, @ckFile, nil, MMIO_FINDRIFF) <> 0) then
          goto ERROR_OPEN;

      { Find the 'data' chunk }
      ckChunk.ckid := $61746164; {'d','a','t','a'};
      if (mmioDescend(hmio, @ckChunk, @ckFile, MMIO_FINDCHUNK) <> 0) then
          goto ERROR_OPEN;

      { allocate some memory for the data chunk }
      iSize := ckChunk.cksize;

      pData := GlobalAllocMem(iSize);
      if (pdata = nil) then
          goto ERROR_OPEN;

      { read the data chunk }
      if (mmioRead(hmio, pdata, iSize) <> iSize) then
          goto ERROR_OPEN;

      { The data chunk should be a LOGPALETTE structure }
      { which we can create a palette from              }

      pLogPal := Pointer(pdata);
      if (pLogPal^.palVersion <> $300) then
          goto ERROR_OPEN;

      { Get the number of entries }
      iColors := pLogPal^.palNumEntries;
      if (iColors <= 0) then
         goto ERROR_OPEN;

      Result := pLogPal;
   end;

ERROR_OPEN:

   if (hmio <> 0) then
       mmioClose(hmio,0);
   if (Result = nil) and (pData <> nil) then
       GlobalFreePtr(pData);
end;

(************************************************************************)
function SavePalette(FName: string; pLogPal: PLOGPALETTE): Boolean;
Label ERROR_SAVE;
var
   {$IFDEF WIN32}
   hmio  : HMMIO;
   {$ELSE}
   hmio  : THMMIO;
   {$ENDIF}
   ckFile: TMMCKINFO;
   ckData: TMMCKINFO;
   iSize : integer;
   aBuf  : array[0..MAX_PATH] of Char;

begin
   Result := False;

   hmio   := 0;

   if pLogPal^.palNumEntries <= 0 then
      goto ERROR_SAVE;

   StrPCopy(aBuf,FName);
   hmio := mmioOpen(aBuf, nil, MMIO_WRITE or MMIO_CREATE or MMIO_ALLOCBUF);
   if (hmio = 0) then
       goto ERROR_SAVE;

   { Create a RIFF chunk for a PAL file }
   ckFile.cksize := 0; { corrected later }
   ckFile.fccType := $204C4150; {'P','A','L',' '};
   if (mmioCreateChunk(hmio, @ckFile, MMIO_CREATERIFF) <> 0) then
       goto ERROR_SAVE;

   iSize := sizeOf(TLogPalette)+sizeOf(TPaletteEntry)*pLogPal^.palNumEntries;

   { create the data chunk }
   ckData.cksize := iSize;
   ckData.ckid := $61746164; {'d','a','t','a'};
   if (mmioCreateChunk(hmio, @ckData, 0) <> 0) then
      goto ERROR_SAVE;

   { write the data chunk }
   if (mmioWrite(hmio, PChar(pLogPal), iSize) <> iSize) then
      goto ERROR_SAVE;

   { Ascend from the data chunk which will correct the length }
   mmioAscend(hmio, @ckData, 0);
   { Ascend from the RIFF/PAL chunk }
   mmioAscend(hmio, @ckFile, 0);

   Result := True;

ERROR_SAVE:

   if (hmio <> 0) then
       mmioClose(hmio, 0);
end;

end.