开通博客赚积分
发布资源赚积分
分类

源码开发语言/平台
当前位置：首页 > 源码/资料 > Delphi控件源码 > 查看源码
MMDIB.pas
资源名称：qqdelphiprog.rar　[点击查看]
上传用户：hylc_2004
上传日期：2014-01-23
资源大小：46800k
文件大小：37k
源码类别：

Delphi控件源码

开发平台：

Delphi

MMDIB.pas：源码内容
  1. {========================================================================}
  2. {=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
  3. {========================================================================}
  4. {=                          All Rights Reserved                         =}
  5. {========================================================================}
  6. {=  D 01099 Dresden             = Tel.: +0351-8012255                   =}
  7. {=  Loewenstr.7a                = info@swiftsoft.de                     =}
  8. {========================================================================}
  9. {=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
  10. {========================================================================}
  11. {=  This code is for reference purposes only and may not be copied or   =}
  12. {=  distributed in any format electronic or otherwise except one copy   =}
  13. {=  for backup purposes.                                                =}
  14. {=                                                                      =}
  15. {=  No Delphi Component Kit or Component individually or in a collection=}
  16. {=  subclassed or otherwise from the code in this unit, or associated   =}
  17. {=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
  18. {=  without express permission from SwiftSoft.                          =}
  19. {=                                                                      =}
  20. {=  For more licence informations please refer to the associated        =}
  21. {=  HelpFile.                                                           =}
  22. {========================================================================}
  23. {=  $Date: 20.01.1998 - 18:00:00 $                                      =}
  24. {========================================================================}
  25. unit MMDIB;
  27. {$I COMPILER.INC}
  29. interface
  31. uses
  32. {$IFDEF WIN32}
  33.   Windows,
  34. {$ELSE}
  35.   WinProcs,
  36.   WinTypes,
  37. {$ENDIF}
  38.   SysUtils,
  39.   MMSystem,
  40.   MMUtils;
  42. const
  43.      {$IFDEF CBUILDER3} {$EXTERNALSYM BFT_ICON } {$ENDIF}
  44.      BFT_ICON     = $4349; { 'IC' }
  45.      {$IFDEF CBUILDER3} {$EXTERNALSYM BFT_BITMAP } {$ENDIF}
  46.      BFT_BITMAP   = $4d42; { 'BM' }
  47.      {$IFDEF CBUILDER3} {$EXTERNALSYM BFT_CURSOR } {$ENDIF}
  48.      BFT_CURSOR   = $5450; { 'PT' }
  50.      {$IFDEF CBUILDER3} {$EXTERNALSYM BI_BITFIELDS } {$ENDIF}
  51.      BI_BITFIELDS = 3;
  52.      {$IFDEF CBUILDER3} {$EXTERNALSYM HALFTONE } {$ENDIF}
  53.      HALFTONE     = COLORONCOLOR;
  55.      { flags for _lseek }
  56.      {$IFDEF CBUILDER3} {$EXTERNALSYM SEEK_CUR } {$ENDIF}
  57.      SEEK_CUR     = 1;
  58.      {$IFDEF CBUILDER3} {$EXTERNALSYM SEEK_END } {$ENDIF}
  59.      SEEK_END     = 2;
  60.      {$IFDEF CBUILDER3} {$EXTERNALSYM SEEK_SET } {$ENDIF}
  61.      SEEK_SET     = 0;
  63.      { flags for orientation }
  64.      TOPDOWN      = -1;
  65.      BOTTOMUP     =  1;
  67. type
  68.     PRGBQUAD   = ^TRGBQUAD;
  69.     PDIB       = PBitmapInfoHeader;
  70.     HDIB       = THandle;
  72. (************************************************************************)
  73. procedure ClearSystemPalette;
  74. function  CreateSystemColorPalette: PLogPalette;
  75. function  LoadPalette(FName: string): PLOGPALETTE;
  76. function  SavePalette(FName: string; pLogPal: PLOGPALETTE): Boolean;
  78. (************************************************************************)
  79. function  DIB_Create(bits, orientation, width, height: integer; AllocBits: Boolean): PDIB;
  80. function  DIB_ReadBitmapInfo(fh: THandle): PDIB;
  81. function  DIB_OpenFile(szFile: PChar): PDIB;
  82. function  DIB_SetUsage(pbi: PDIB; hPal: HPALETTE; wUsage: UINT): Boolean;
  83. procedure DIB_MapToPalette(var pbi: PDIB; hpal: HPALETTE);
  84. procedure DIB_Display(pbi: PDIB; DC: HDC; aRect: TRect);
  85. function  DIB_BitmapToDIB(Handle: HBitmap; Palette: HPalette;
  86.                           Bits, Orientation: integer): PDIB;
  87. procedure DIB_DIBToBitmap(pbi: PDIB; var Bitmap: HBitmap;
  88.                           var Pal: HPalette);
  90. (************************************************************************)
  91. function  IsWinDIB(pbi: PBITMAPINFOHEADER): Boolean;
  92. function  HandleFrom_DIB(lpbi: PDIB): THandle;
  93. function  DIB_FromHandle(h: THandle): PDIB;
  94. procedure DIB_Free(lpbi: PDIB);
  95. function  DIB_Width(lpbi: PDIB): integer;
  96. function  DIB_Height(lpbi: PDIB): integer;
  97. function  DIB_BitCount(lpbi: PDIB): integer;
  98. function  DIB_Compression(lpbi: PDIB): Longint;
  99. function  DIB_NumColors(lpbi: PDIB): Longint;
  100. function  DIB_WidthBytesN(lpbi: PDIB; n: integer): Longint;
  101. function  DIB_WidthBytes(lpbi: PDIB): Longint;
  102. function  DIB_BISize(lpbi: PDIB): integer;
  103. function  DIB_SizeImage(lpbi: PDIB): Longint;
  104. function  DIB_Size(lpbi: PDIB): Longint;
  105. function  DIB_PaletteSize(lpbi: PDIB): DWORD;
  106. function  DIB_FlipY(lpbi: PDIB; y: integer): integer;
  107. function  DIB_Colors(lpbi: PDIB): PRGBQUAD;
  108. function  DIB_Ptr(lpbi: PDIB): Pointer;
  109. function  DIB_XYN(lpbi: PDIB; pb: Pointer; x,y,n: integer): Pointer;
  110. function  DIB_XY(lpbi: PDIB;x,y: integer): Pointer;
  111. function  DIB_Info(pDIB: PDIB): PBitmapInfo;
  113. implementation
  115. {$IFNDEF WIN32}
  116. function _hread(hFile: THANDLE; lpBuffer: Pointer; lBytes: Longint): Longint;
  117. Far; external 'KERNEL' name '_hread';
  118. {$ENDIF}
  120. (************************************************************************)
  121. function IsWinDIB(pbi: PDIB): Boolean;
  122. begin
  123.    if (pbi^.biSize <> sizeof(TBITMAPINFOHEADER)) then
  124.        Result := False
  125.    else
  126.        Result := True;
  127. end;
  129. (************************************************************************)
  130. function HandleFrom_DIB(lpbi: PDIB): THandle;
  131. begin
  132.    {$IFDEF WIN32}
  133.    Result := GlobalHandle(lpbi);
  134.    {$ELSE}
  135.    Result := GlobalHandle(SELECTOROF(lpbi));
  136.    {$ENDIF}
  137. end;
  139. (************************************************************************)
  140. function DIB_FromHandle(h: THandle): PDIB;
  141. begin
  142.    Result := GlobalLock(h);
  143. end;
  145. (************************************************************************)
  146. procedure DIB_Free(lpbi: PDIB);
  147. begin
  148.    if (lpbi <> nil) then GlobalFreePtr(lpbi);
  149. end;
  151. (************************************************************************)
  152. function WIDTHBYTES(i: Longint): Longint;
  153. begin
  154.    Result := ((i+31) and not 31) div 8;  { DWORD aligned ! }
  155. end;
  157. (************************************************************************)
  158. function DIB_Width(lpbi: PDIB): integer;
  159. begin
  160.    Result := lpbi^.biWidth;
  161. end;
  163. (************************************************************************)
  164. function DIB_Height(lpbi: PDIB): integer;
  165. begin
  166.    Result := lpbi^.biHeight;
  167. end;
  169. (************************************************************************)
  170. function DIB_BitCount(lpbi: PDIB): integer;
  171. begin
  172.     if IsWinDIB(lpbi) then
  173.        Result := lpbi^.biBitCount
  174.     else
  175.        Result := PBitmapCoreHeader(lpbi)^.bcBitCount;
  176. end;
  178. (************************************************************************)
  179. function DIB_Compression(lpbi: PDIB): Longint;
  180. begin
  181.    Result := lpbi^.biCompression;
  182. end;
  184. (************************************************************************)
  185. function DIB_NumColors(lpbi: PDIB): Longint;
  186. begin
  187.    if (lpbi^.biClrUsed = 0) and (lpbi^.biBitCount <= 8) then
  188.       Result := (1 shl lpbi^.biBitCount)
  189.     else
  190.       Result := lpbi^.biClrUsed;
  191. end;
  193. (************************************************************************)
  194. function DIB_WidthBytesN(lpbi: PDIB; n: integer): Longint;
  195. begin
  196.    Result := WIDTHBYTES(lpbi^.biWidth * Long(n));
  197. end;
  199. (************************************************************************)
  200. function DIB_WidthBytes(lpbi: PDIB): Longint;
  201. begin
  202.    Result := DIB_WidthBytesN(lpbi, lpbi^.biBitCount);
  203. end;
  205. (************************************************************************)
  206. function DIB_BISize(lpbi: PDIB): integer;
  207. begin
  208.    Result := lpbi^.biSize + DWORD(DIB_PaletteSize(lpbi));
  209. end;
  211. (************************************************************************)
  212. function DIB_SizeImage(lpbi: PDIB): Longint;
  213. begin
  214.    if (lpbi^.biSizeImage = 0) then
  215.       Result :=  DIB_WidthBytes(lpbi) * Long(lpbi^.biHeight)
  216.    else
  217.       Result := lpbi^.biSizeImage;
  218. end;
  220. (************************************************************************)
  221. function DIB_Size(lpbi: PDIB): Longint;
  222. begin
  223.    Result := lpbi^.biSize + lpbi^.biSizeImage + (lpbi^.biClrUsed * sizeof(TRGBQUAD));
  224. end;
  226. (************************************************************************)
  227. function DIB_PaletteSize(lpbi: PDIB): DWORD;
  228. begin
  229.    Result := DIB_NumColors(lpbi) * sizeof(TRGBQUAD);
  230. end;
  232. (************************************************************************)
  233. function DIB_FlipY(lpbi: PDIB; y: integer): integer;
  234. begin
  235.    Result := lpbi^.biHeight-1-y;
  236. end;
  238. (************************************************************************)
  239. function DIB_Colors(lpbi: PDIB): PRGBQUAD;
  240. begin
  241.    Result := PRGBQUAD(PChar(lpbi) + lpbi^.biSize);
  242. end;
  244. (************************************************************************)
  245. function DIB_Ptr(lpbi: PDIB): Pointer;
  246. begin
  247.    {$IFDEF WIN32}
  248.    { HACK for NT BI_BITFIELDS DIBs }
  249.    if (lpbi^.biCompression = BI_BITFIELDS) then
  250.       Result := PChar(DIB_Colors(lpbi)) + 3 * sizeof(TRGBQUAD)
  251.    else
  252.    {$ENDIF}
  253.      Result := PChar(DIB_Colors(lpbi)) + lpbi^.biClrUsed * sizeof(TRGBQUAD);
  254. end;
  256. (************************************************************************)
  257. function DIB_XYN(lpbi: PDIB; pb: Pointer; x,y,n: integer): Pointer;
  258. begin
  259.    Result := pb;
  260.    incHuge(Result,Long(x)*Long(n) div Long(8)+DIB_WidthBytesN(lpbi,n)*Long(y));
  261. end;
  263. (************************************************************************)
  264. function DIB_XY(lpbi: PDIB;x,y: integer): Pointer;
  265. begin
  266.    Result := DIB_XYN(lpbi,DIB_Ptr(lpbi),x,y,lpbi^.biBitCount);
  267. end;
  269. (************************************************************************)
  270. procedure FixBitmapInfo(lpbi: PDIB);
  271. begin
  272.    if (lpbi^.biSizeImage = 0) then
  273.        lpbi^.biSizeImage := DIB_SizeImage(lpbi);
  275.    if (lpbi^.biClrUsed = 0) then
  276.        lpbi^.biClrUsed := DIB_NumColors(lpbi);
  278.    if (lpbi^.biCompression = BI_BITFIELDS) and (lpbi^.biClrUsed = 0) then
  279.        lpbi^.biClrUsed := 3;
  280. end;
  282. (************************************************************************)
  283. function DIB_Info(pDIB: PDIB): PBitmapInfo;
  284. begin
  285.    Result := Pointer(pDIB);
  286. end;
  288. (************************************************************************)
  289. (*  Clear the System Palette so that we can ensure an identity palette  *)
  290. (*  mapping for fast performance.                                       *)
  291. (************************************************************************)
  292. procedure ClearSystemPalette;
  293. type
  294.    { Logical Palette }
  295.    TLogPal = record
  296.     palVersion: Word;
  297.     palNumEntries: Word;
  298.     palEntry: array[0..256] of TPaletteEntry;
  299.   end;
  301. var
  302.    i: integer;
  303.    LogPal: TLogPal;
  304.    ScreenPal: HPalette;
  305.    ScreenDC: HDC;
  307. begin
  308.    with LogPal do
  309.    begin
  310.       palVersion := $300;
  311.       palNumEntries := 256;
  313.       { Reset everything in the system palette to black }
  314.       for i := 0 to 255 do
  315.       begin
  316.          palEntry[i].peRed := 0;
  317.          palEntry[i].peGreen := 0;
  318.          palEntry[i].peBlue := 0;
  319.          palEntry[i].peFlags := PC_NOCOLLAPSE;
  320.       end;
  322.       { Create, select, realize, deselect, and delete the palette }
  323.       ScreenDC := GetDC(0);
  324.       ScreenPal := CreatePalette(PLogPalette(@LogPal)^);
  326.       if (ScreenPal <> 0) then
  327.       begin
  328.          ScreenPal := SelectPalette(ScreenDC,ScreenPal,False);
  329.          RealizePalette(ScreenDC);
  330.          ScreenPal := SelectPalette(ScreenDC,ScreenPal,False);
  331.          DeleteObject(ScreenPal);
  332.       end;
  333.       ReleaseDC(0, ScreenDC);
  334.    end;
  335. end;
  337. (************************************************************************)
  338. function CreateSystemColorPalette: PLogPalette;
  339. type
  340.    { Logical Palette }
  341.    PLogPal = ^TLogPal;
  342.    TLogPal = record
  343.     palVersion: Word;
  344.     palNumEntries: Word;
  345.     palEntry: array[0..256] of TPaletteEntry;
  346.   end;
  348. var
  349.    DC: HDC;
  350.    Size: integer;
  351.    pPal: PLogPal;
  353. begin
  354.    { Get a screen DC to work with }
  355.    DC := GetDC(0);
  356.    try
  357.       { allocate a log pal and fill it with the color table info }
  358.       Size := sizeof(TLogPalette) + 256 * sizeOf(TPaletteEntry);
  359.       pPal := GlobalAllocMem(Size);
  360.       FillChar(pPal^, Size, 0);
  361.       with pPal^ do
  362.       begin
  363.          palVersion := $300;   { Windows 3.0 }
  364.          palNumEntries := 256; { table size  }
  366.          { Make sure we are on a palettized device }
  367.          if (GetDeviceCaps(DC, RASTERCAPS) and RC_PALETTE <> 0) and
  368.             (GetDeviceCaps(DC, NUMCOLORS) <= 256) then
  369.          begin
  370.             { Get the system colors in the first and last 10 slots }
  371.             GetSystemPaletteEntries(DC, 0, 10, palEntry);
  372.             GetSystemPaletteEntries(DC, 246, 10, palEntry[246]);
  373.          end
  374.          else
  375.          begin
  376.             { set the entrys by hand }
  377.             Longint(palEntry[0])  := RGB($00,$00,$00); { black        }
  378.             Longint(palEntry[1])  := RGB($80,$00,$00); { dark red     }
  379.             Longint(palEntry[2])  := RGB($00,$80,$00); { dark green   }
  380.             Longint(palEntry[3])  := RGB($80,$80,$00); { dark yellow  }
  381.             Longint(palEntry[4])  := RGB($00,$00,$80); { dark blue    }
  382.             Longint(palEntry[5])  := RGB($80,$00,$80); { dark magneta }
  383.             Longint(palEntry[6])  := RGB($00,$80,$80); { dark cyan    }
  384.             Longint(palEntry[7])  := RGB($C0,$C0,$C0); { light gray   }
  385.             Longint(palEntry[8])  := RGB($C0,$DC,$C0); { money green  }
  386.             Longint(palEntry[9])  := RGB($A6,$CA,$F0); { sky blue     }
  387.             Longint(palEntry[246]):= RGB($FF,$FB,$F0); { cream        }
  388.             Longint(palEntry[247]):= RGB($A0,$A0,$A4); { medium gray  }
  389.             Longint(palEntry[248]):= RGB($80,$80,$80); { dark gray    }
  390.             Longint(palEntry[249]):= RGB($FF,$00,$00); { red          }
  391.             Longint(palEntry[250]):= RGB($00,$FF,$00); { green        }
  392.             Longint(palEntry[251]):= RGB($FF,$FF,$00); { yellow       }
  393.             Longint(palEntry[252]):= RGB($00,$00,$FF); { blue         }
  394.             Longint(palEntry[253]):= RGB($FF,$00,$FF); { magneta      }
  395.             Longint(palEntry[254]):= RGB($00,$FF,$FF); { cyan         }
  396.             Longint(palEntry[255]):= RGB($FF,$FF,$FF); { white        }
  397.          end;
  398.       end;
  400.    finally
  401.       ReleaseDC(0,DC);
  402.    end;
  403.    Result := PLogPalette(pPal);
  404. end;
  406. {$IFNDEF WIN32}
  407. const
  408.   HFILE_ERROR = -1;
  409. {$ENDIF}
  411. (************************************************************************)
  412. (* Open a DIB file and return a MEMORY DIB, a memory handle containing..*)
  413. (************************************************************************)
  414. function DIB_OpenFile(szFile: PChar): PDIB;
  415. var
  416.    fh: THandle;
  417.    dwLen: DWORD;
  418.    dwBits: DWORD;
  419.    pd: PDIB;
  420.    p: Pointer;
  421.    ofs: TOFSTRUCT;
  422.    h: THandle;
  424. begin
  425.    Result := nil;
  426.    fh := OpenFile(szFile, ofs, OF_READ);
  428.    if (fh = HFILE_ERROR) then
  429.    begin
  430.       h := FindResource(HInstance, szFile, RT_BITMAP);
  432.       if (h <> 0) then
  433.       begin
  434.          {$IFDEF WIN32}
  435.          { !!! can we call GlobalFree() on this? is it the right format. }
  436.          { !!! can we write to this resource?                            }
  437.          Result := PDIB(LockResource(LoadResource(HInstance, h)));
  438.          exit;
  439.          {$ELSE}
  440.          fh := AccessResource(HInstance, h);
  441.          {$ENDIF}
  442.       end;
  443.    end;
  445.    if (fh = HFILE_ERROR) then exit;
  447.    pd := DIB_ReadBitmapInfo(fh);
  448.    if (pd = nil) then exit;
  450.    { How much memory do we need to hold the DIB }
  451.    dwBits := pd^.biSizeImage;
  452.    dwLen  := pd^.biSize + DIB_PaletteSize(pd) + dwBits;
  454.    { Can we get more memory? }
  455.    p := GlobalReAllocPtr(pd,dwLen,0);
  456.    if (p = nil) then
  457.    begin
  458.       GlobalFreePtr(pd);
  459.       pd := Nil;
  460.    end
  461.    else pd := PDIB(p);
  463.    if (pd <> nil) then
  464.    begin
  465.       { read in the bits }
  466.       _hread(fh, PChar(pd) + pd^.biSize + DIB_PaletteSize(pd), dwBits);
  467.    end;
  469.    _lclose(fh);
  470.    Result := pd;
  471. end;
  473. (************************************************************************)
  474. (*  ReadDibBitmapInfo()                                                 *)
  475. (*                                                                      *)
  476. (*  Will read a file in DIB format and return a global HANDLE to its    *)
  477. (*  BITMAPINFO.  This function will work with both "old" and "new"      *)
  478. (*  bitmap formats, but will always return a "new" BITMAPINFO.          *)
  479. (************************************************************************)
  480. function DIB_ReadBitmapInfo(fh: THANDLE): PDIB;
  481. type
  482.     PRGBTRIPLE = ^RGBTRIPLE;
  483.     RGBTRIPLE  = array[0..0] of TRGBTRIPLE;
  485.     PRGBQUAD = ^RGBQUAD;
  486.     RGBQUAD  = array[0..0] of TRGBQUAD;
  488. var
  489.    off: DWORD;
  490.    size, i: integer;
  491.    nNumColors: DWORD;
  492.    pRGB: PRGBQUAD;
  493.    RGB: TRGBQUAD;
  494.    bi: TBITMAPINFOHEADER;
  495.    bc: TBITMAPCOREHEADER;
  496.    bf: TBITMAPFILEHEADER;
  497.    pd: PDIB;
  499. begin
  500.    Result := nil;
  502.    if (fh = HFILE_ERROR) then exit;
  504.    off := _llseek(fh,0,SEEK_CUR);
  506.    if (sizeof(bf) <> _lread(fh,@bf,sizeof(bf))) then exit;
  508.    { do we have a RC HEADER? }
  509.    if (bf.bfType <> BFT_BITMAP) then
  510.    begin
  511.       bf.bfOffBits := 0;
  512.       _llseek(fh,off,SEEK_SET);
  513.    end;
  515.    if (sizeof(bi) <> _lread(fh,@bi,sizeof(bi))) then exit;
  517.    { what type of bitmap info is this? }
  518.    size := bi.biSize;
  519.    if (size = sizeof(TBITMAPCOREHEADER)) then
  520.    begin
  521.       bc := PBITMAPCOREHEADER(@bi)^;
  522.       bi.biSize          := sizeof(TBITMAPINFOHEADER);
  523.       bi.biWidth         := bc.bcWidth;
  524.       bi.biHeight        := bc.bcHeight;
  525.       bi.biPlanes        := bc.bcPlanes;
  526.       bi.biBitCount      := bc.bcBitCount;
  527.       bi.biCompression   := BI_RGB;
  528.       bi.biSizeImage     := 0;
  529.       bi.biXPelsPerMeter := 0;
  530.       bi.biYPelsPerMeter := 0;
  531.       bi.biClrUsed       := 0;
  532.       bi.biClrImportant  := 0;
  533.       _llseek(fh,sizeof(TBITMAPCOREHEADER)-sizeof(TBITMAPINFOHEADER),SEEK_CUR);
  534.    end;
  536.    nNumColors := DIB_NumColors(@bi);
  538.    FixBitmapInfo(@bi);
  540.    pd := GlobalAllocMem(bi.biSize + nNumColors * sizeof(TRGBQUAD));
  542.    if (pd = nil) then exit;
  544.    pd^ := bi;
  546.    pRgb := PRGBQUAD(DIB_Colors(pd));
  548.    if (nNumColors > 0) then
  549.    begin
  550.       if (size = sizeof(TBITMAPCOREHEADER)) then
  551.       begin
  552.          { convert a old color table (3 byte entries) to a new }
  553.          { color table (4 byte entries)                        }
  554.          _lread(fh,PChar(pRgb),nNumColors * sizeof(TRGBTRIPLE));
  556.          for i := nNumColors-1 downTo 0 do
  557.          begin
  558.             rgb.rgbRed      := PRGBTRIPLE(pRgb)^[i].rgbtRed;
  559.             rgb.rgbBlue     := PRGBTRIPLE(pRgb)^[i].rgbtBlue;
  560.             rgb.rgbGreen    := PRGBTRIPLE(pRgb)^[i].rgbtGreen;
  561.             rgb.rgbReserved := 0;
  563.             pRgb^[i] := rgb;
  564.          end;
  565.       end
  566.       else _lread(fh,PChar(pRgb),nNumColors * sizeof(TRGBQUAD));
  567.    end;
  569.    if (bf.bfOffBits <> 0) then
  570.       _llseek(fh,off + bf.bfOffBits,SEEK_SET);
  572.    Result := pd;
  573. end;
  575. (************************************************************************)
  576. (*  DibSetUsage(hdib,hpal,wUsage)                                       *)
  577. (*                                                                      *)
  578. (*  Modifies the color table of the passed DIB for use with the wUsage  *)
  579. (*  parameter specifed.                                                 *)
  580. (*                                                                      *)
  581. (*  if wUsage is DIB_PAL_COLORS the DIB color table is set to 0-256     *)
  582. (*  if wUsage is DIB_RGB_COLORS the DIB color table is set to the RGB   *)
  583. (*  values in the passed palette                                        *)
  584. (************************************************************************)
  585. function DIB_SetUsage(pbi: PDIB; hPal: HPALETTE; wUsage: UINT): Boolean;
  586. type
  587.     PRGBQUAD = ^RGBQUAD;
  588.     RGBQUAD  = array[0..0] of TRGBQUAD;
  590. var
  591.    ape: array[0..255] of TPALETTEENTRY;
  592.    pRGB: PRGBQUAD;
  593.    pw: PWord;
  594.    nColors: Longint;
  595.    i: integer;
  597. begin
  598.    Result := False;
  600.    if (pbi = nil) then exit;
  602.    if (hpal = 0) then
  603.        hpal := GetStockObject(DEFAULT_PALETTE);
  605.     nColors := DIB_NumColors(pbi);
  607.     if (nColors = 3) and (DIB_Compression(pbi) = BI_BITFIELDS) then
  608.         nColors := 0;
  610.     if (nColors > 0) then
  611.     begin
  612.        pRgb := PRGBQUAD(DIB_Colors(pbi));
  614.        case wUsage of
  615.           DIB_PAL_COLORS:
  616.           begin
  617.              { Set the DIB color table to palette indexes }
  618.              pw := Pointer(pRgb);
  619.              for i := 0 to nColors-1 do
  620.              begin
  621.                 pw^ := i;
  622.                 inc(pw);
  623.              end;
  624.           end;
  625.           else
  626.           begin
  627.              { Set the DIB color table to RGBQUADS }
  628.              { DIB_RGB_COLORS:                     }
  629.              nColors := min(nColors,256);
  630.              GetPaletteEntries(hpal,0,nColors,ape);
  631.              for i := 0 to nColors-1 do
  632.              begin
  633.                 pRgb^[i].rgbRed      := ape[i].peRed;
  634.                 pRgb^[i].rgbGreen    := ape[i].peGreen;
  635.                 pRgb^[i].rgbBlue     := ape[i].peBlue;
  636.                 pRgb^[i].rgbReserved := 0;
  637.              end;
  638.           end;
  639.        end;
  640.     end;
  641.     Result := True;
  642. end;
  644. (************************************************************************)
  645. (*  Dib_Create                                                          *)
  646. (*                                                                      *)
  647. (*  Creates a new packed DIB with the given dimensions and the          *)
  648. (*  given number of bits per pixel                                      *)
  649. (*                                                                      *)
  650. (*  Orientation: -1 = TOP_DOWN, 1 = BOTTOM_UP                           *)
  651. (************************************************************************)
  652. function DIB_Create(Bits, Orientation, Width, Height: integer; AllocBits: Boolean): PDIB;
  653. var
  654.    pbi: PDIB;
  655.    i: integer;
  656.    pdw: PLongint;
  657.    dwSizeImage: Longint;
  659. begin
  660.    Result := nil;
  661.    width := Max(width,1);
  662.    height := Max(height,1);
  663.    if (Bits > 8) and (Bits <> 24) then Bits := 24;
  665.    if AllocBits then
  666.       dwSizeImage := WIDTHBYTES(Longint(Width)*Bits) * Height
  667.    else
  668.       dwSizeImage := 0;
  670.    pbi := GlobalAllocMem(sizeof(TBITMAPINFOHEADER)+dwSizeImage+256*sizeOf(TRGBQuad));
  671.    if (pbi = nil) then exit;
  673.    pbi^.biSize          := sizeof(TBITMAPINFOHEADER);
  674.    pbi^.biWidth         := Width;
  675.    pbi^.biHeight        := Height * Orientation;
  676.    pbi^.biPlanes        := 1;
  677.    pbi^.biBitCount      := Bits;
  678.    pbi^.biCompression   := BI_RGB;
  679.    pbi^.biSizeImage     := dwSizeImage;
  680.    pbi^.biXPelsPerMeter := 0;
  681.    pbi^.biYPelsPerMeter := 0;
  682.    pbi^.biClrUsed       := 0;
  683.    pbi^.biClrImportant  := 0;
  685.    if (bits = 4) then
  686.        pbi^.biClrUsed := 16
  687.    else if (bits = 8) then
  688.        pbi^.biClrUsed := 256;
  690.    pdw := PLongint(PChar(pbi)+pbi^.biSize);
  692.    for i := 0 to (pbi^.biClrUsed div 16)-1 do
  693.    begin
  694.       pdw^ := $00000000;    { 0000  black          }
  695.       inc(pdw);
  696.       pdw^ := $00800000;    { 0001  dark red       }
  697.       inc(pdw);
  698.       pdw^ := $00008000;    { 0010  dark green     }
  699.       inc(pdw);
  700.       pdw^ := $00808000;    { 0011  mustard        }
  701.       inc(pdw);
  702.       pdw^ := $00000080;    { 0100  dark blue      }
  703.       inc(pdw);
  704.       pdw^ := $00800080;    { 0101  purple         }
  705.       inc(pdw);
  706.       pdw^ := $00008080;    { 0110  dark turquoise }
  707.       inc(pdw);
  708.       pdw^ := $00C0C0C0;    { 1000  gray           }
  709.       inc(pdw);
  710.       pdw^ := $00808080;    { 0111  dark gray      }
  711.       inc(pdw);
  712.       pdw^ := $00FF0000;    { 1001  red            }
  713.       inc(pdw);
  714.       pdw^ := $0000FF00;    { 1010  green          }
  715.       inc(pdw);
  716.       pdw^ := $00FFFF00;    { 1011  yellow         }
  717.       inc(pdw);
  718.       pdw^ := $000000FF;    { 1100  blue           }
  719.       inc(pdw);
  720.       pdw^ := $00FF00FF;    { 1101  pink (magenta) }
  721.       inc(pdw);
  722.       pdw^ := $0000FFFF;    { 1110  cyan           }
  723.       inc(pdw);
  724.       pdw^ := $00FFFFFF;    { 1111  white          }
  725.    end;
  726.    Result := pbi;
  727. end;
  729. (************************************************************************)
  730. procedure xlatClut8(pb: PByte; dwSize: DWORD; xlat: PByteArray);
  731. var
  732.    dw: DWORD;
  734. begin
  735.    for dw := 0 to dwSize-1 do
  736.    begin
  737.       pb^ := xlat^[pb^];
  738.       incHuge(pb,sizeOf(pB^));
  739.    end;
  740. end;
  742. (************************************************************************)
  743. procedure xlatClut4(pb: PByte; dwSize: DWORD; xlat: PByteArray);
  744. var
  745.    dw: DWORD;
  747. begin
  748.    for dw := 0 to dwSize-1 do
  749.    begin
  750.       pb^ := xlat^[pb^ and $0F] or (xlat^[(pb^ shr 4) and $0F] shl 4);
  751.       incHuge(pb,sizeOf(pB^));
  752.    end;
  753. end;
  755. (************************************************************************)
  756. procedure xlatRle8(pb: PByte; dwSize: DWORD; xlat: PByteArray);
  757. const
  758.      RLE_ESCAPE = 0;
  759.      RLE_EOL    = 0;
  760.      RLE_EOF    = 1;
  761.      RLE_JMP    = 2;
  762. var
  763.    b,cnt: Byte;
  764.    prle: PByte;
  766. begin
  767.    prle := pb;
  769.    while True do
  770.    begin
  771.       cnt := prle^;
  772.       incHuge(prle,1);
  773.       b   := prle^;
  775.       if (cnt = RLE_ESCAPE) then
  776.       begin
  777.          incHuge(prle,1);
  779.          case b of
  780.             RLE_EOF: exit;
  781.             RLE_EOL: ;
  783.             RLE_JMP: incHuge(prle,2); { skip dX,dY }
  784.             else
  785.             begin
  786.                cnt := b;
  787.                for b := 0 to cnt-1 do
  788.                begin
  789.                   prle^ := xlat^[prle^];
  790.                   incHuge(prle,1);
  791.                end;
  792.                if (cnt and 1 > 0) then incHuge(prle,1);
  793.             end;
  794.          end;
  795.       end
  796.       else
  797.       begin
  798.          prle^:= xlat^[b];
  799.          incHuge(prle,1);
  800.       end;
  801.    end;
  802. end;
  804. (************************************************************************)
  805. procedure xlatRle4(pb: PByte; dwSize: DWORD; xlat: PByteArray);
  806. begin
  807. end;
  809. (************************************************************************)
  810. (*  DibMapToPalette(pdib, hpal)                                         *)
  811. (*                                                                      *)
  812. (*  Map the colors of the DIB, using GetNearestPaletteIndex, to         *)
  813. (*  the colors of the given palette.                                    *)
  814. (************************************************************************)
  815. procedure DIB_MapToPalette(var pbi: PDIB; hpal: HPALETTE);
  816. type
  817.     PRGBQUAD = ^RGBQUAD;
  818.     RGBQUAD  = array[0..0] of TRGBQUAD;
  819. var
  820.    pe: TPALETTEENTRY;
  821.    i: integer;
  822.    nDibColors: DWORD;
  823.    nPalColors: DWORD;
  824.    lpBits,p: PByte;
  825.    pRGB: PRGBQUAD;
  826.    xlat: array[0..255] of Byte;
  827.    SizeImage: DWORD;
  829. begin
  830.    nPalColors := 0;
  832.    if (hpal = 0) or (pbi = nil) then exit;
  834.    pRgb := PRGBQUAD(DIB_Colors(pbi));
  836.    GetObject(hpal,sizeof(Word),@nPalColors);
  837.    nDibColors := DIB_NumColors(pbi);
  839.    SizeImage := pbi^.biSizeImage;
  840.    if (SizeImage = 0) then
  841.        SizeImage := DIB_SizeImage(pbi);
  843.    { build a xlat table. from the current DIB colors to the given }
  844.    { palette.                                                     }
  845.    for i := 0 to nDibColors-1 do
  846.        xlat[i] := GetNearestPaletteIndex(hpal,RGB(pRgb^[i].rgbRed,pRgb^[i].rgbGreen,pRgb^[i].rgbBlue));
  848.    lpBits := DIB_Ptr(pbi);
  849.    pbi^.biClrUsed := nPalColors;
  851.    { re-size the DIB }
  852.    if (nPalColors > nDibColors) then
  853.    begin
  854.       GlobalReAllocPtr(pbi, pbi^.biSize + nPalColors*sizeof(TRGBQUAD) + SizeImage, 0);
  855.       p := DIB_Ptr(pbi);
  856.       GlobalMoveMem(lpBits^, p^, SizeImage);
  857.       lpBits := DIB_Ptr(pbi);
  858.    end
  859.    else if (nPalColors < nDibColors) then
  860.    begin
  861.       p := DIB_Ptr(pbi);
  862.       GlobalMoveMem(lpBits^, p^, SizeImage);
  863.       GlobalReAllocPtr(pbi, pbi^.biSize + nPalColors*sizeof(TRGBQUAD) + SizeImage, 0);
  864.       lpBits := DIB_Ptr(pbi);
  865.    end;
  867.    { translate the DIB bits }
  868.    case pbi^.biCompression of
  869.        BI_RLE8: xlatRle8(lpBits, SizeImage, @xlat);
  870.        BI_RLE4: xlatRle4(lpBits, SizeImage, @xlat);
  871.        BI_RGB:
  872.        begin
  873.           if (pbi^.biBitCount = 8) then
  874.               xlatClut8(lpBits, SizeImage, @xlat)
  875.           else
  876.               xlatClut4(lpBits, SizeImage, @xlat);
  877.        end;
  878.    end;
  880.    { Now copy the RGBs in the logical palette to the dib color table }
  881.    for i := 0 to nPalColors-1 do
  882.    begin
  883.       GetPaletteEntries(hpal,i,1,pe);
  884.       pRgb^[i].rgbRed      := pe.peRed;
  885.       pRgb^[i].rgbGreen    := pe.peGreen;
  886.       pRgb^[i].rgbBlue     := pe.peBlue;
  887.       pRgb^[i].rgbReserved := 0;
  888.    end;
  889. end;
  891. (************************************************************************)
  892. function DIB_CreatePalette(pbi: PDIB): HPALETTE;
  893. var
  894.   R,G,B: Byte;
  895.   DstPal: PLogPalette;
  896.   Colors: integer;
  897.   DC: HDC;
  898.   Focus: HWND;
  899.   SysPalSize: Integer;
  900.   Size: Longint;
  901.   i: Integer;
  903. begin
  904.    Result := 0;
  906.    Colors := DIB_NumColors(pbi);
  907.    if Colors <> 0 then
  908.    begin
  909.       Size := SizeOf(TLogPalette) + ((Colors - 1) * SizeOf(TPaletteEntry));
  910.       DstPal := GlobalAllocMem(Size);
  911.       try
  912.          with DstPal^ do
  913.          begin
  914.             palNumEntries := Colors;
  915.             palVersion := $300;
  916.             Focus := GetFocus;
  917.             DC := GetDC(Focus);
  918.             try
  919.                SysPalSize := GetDeviceCaps(DC, SIZEPALETTE);
  920.                if (Colors = 16) and (SysPalSize >= 16) then
  921.                begin
  922.                   { Ignore the disk image of the palette for 16 color }
  923.                   { bitmaps use instead the first 8 and last 8 of the }
  924.                   { current system palette                            }
  925.                   GetSystemPaletteEntries(DC, 0, 8, palPalEntry);
  926.                   i := 8;
  927.                   GetSystemPaletteEntries(DC, SysPalSize - i, i, palPalEntry[i]);
  928.                end
  929.                else
  930.                for i := 0 to Colors-1 do
  931.                with palPalEntry[i] do
  932.                begin
  933.                   { Copy the palette for all others (i.e. 256 colors) }
  934.                   peRed := PBitmapInfo(pbi)^.bmiColors[i].rgbRed;
  935.                   peGreen := PBitmapInfo(pbi)^.bmiColors[i].rgbGreen;
  936.                   peBlue := PBitmapInfo(pbi)^.bmiColors[i].rgbBlue;
  937.                   peFlags := 0;
  938.                end;
  940.             finally
  941.                ReleaseDC(Focus, DC);
  942.             end;
  943.          end;
  944.          Result := CreatePalette(DstPal^);
  946.       finally
  947.          GlobalFreePtr(DstPal);
  948.       end;
  949.    end
  950.    else if DIB_BitCount(pbi) = 24 then
  951.    begin
  952.       Colors:= 256;
  953.       Size:= SizeOf(TLogPalette) + (Colors-1) * SizeOf(TPaletteEntry);
  954.       DstPal := GlobalAllocMem(Size);
  955.       try
  956.          with DstPal^ do
  957.          begin
  958.             palVersion:= $300;
  959.             palNumEntries:= Colors;
  960.             R:= 0;
  961.             G:= 0;
  962.             B:= 0;
  963.             for i := 0 to Colors-1 do
  964.             with palPalEntry[i] do
  965.             begin
  966.                peRed:= R;
  967.                peGreen:= G;
  968.                peBlue:= B;
  969.                peFlags:= 0;
  971.                Inc(R, 32);
  972.                if (R = 0) then
  973.                begin
  974.                   Inc(G, 32);
  975.                   if (G = 0) then Inc(B, 64);
  976.                end;
  977.             end;
  978.          end;
  979.          Result:= CreatePalette(DstPal^);
  981.       finally
  982.          GlobalFreePtr(DstPal);
  983.       end;
  984.    end;
  985. end;
  987. (************************************************************************)
  988. procedure DIB_Display(pbi: PDIB; DC: HDC; aRect: TRect);
  989. var
  990.    OldPal,Pal: HPalette;
  992. begin
  993.    OldPal := 0;
  994.    Pal := DIB_CreatePalette(pbi);
  996.    if Pal <> 0 then
  997.    begin
  998.       OldPal := SelectPalette(DC, Pal, False);
  999.       RealizePalette(DC);
  1000.    end;
  1002.    SetStretchBltMode(DC, STRETCH_DELETESCANS);
  1003.    StretchDIBits(DC, aRect.Left,aRect.Top,
  1004.                      aRect.Right-aRect.Left, aRect.Bottom-aRect.Top,
  1005.                      0, 0, DIB_WIDTH(pBi), DIB_Height(pBi),
  1006.                      DIB_PTR(pbi), PBitmapInfo(pbI)^,
  1007.                      DIB_RGB_COLORS, SRCCOPY);
  1009.    if (OldPal <> 0) then
  1010.    begin
  1011.       SelectPalette(DC, OldPal, False);
  1012.       DeleteObject(Pal);
  1013.    end;
  1014. end;
  1016. (************************************************************************)
  1017. function DIB_BitmapToDIB(Handle: HBitmap; Palette: HPalette;
  1018.                          Bits, Orientation: integer): PDIB;
  1019. var
  1020.    lpbi: PDIB;
  1021.    lpBits: PByte;
  1022.    BM: TBitmap;
  1023.    OldPal: HPALETTE;
  1024.    DC: HDC;
  1025.    Focus: HWND;
  1027. begin
  1028.    Result := nil;
  1029.    GetObject(Handle, sizeOf(TBitmap), @BM);
  1031.    lpbi := DIB_Create(Bits, Orientation, BM.bmWidth, BM.bmHeight, True);
  1032.    if (lpbi <> nil) then
  1033.    with lpbi^ do
  1034.    begin
  1035.       OldPal := 0;
  1036.       Focus := GetFocus;
  1037.       DC := GetDC(Focus);
  1038.       try
  1039.          if Palette <> 0 then
  1040.          begin
  1041.             OldPal := SelectPalette(DC, Palette, False);
  1042.             RealizePalette(DC);
  1043.          end;
  1044.          lpBits := DIB_PTR(lpbi);
  1045.          if GetDIBits(DC, Handle, 0, BM.bmHeight, lpBits, PBitmapInfo(lpbi)^, DIB_RGB_COLORS) = 0 then
  1046.             DIB_Free(lpbi)
  1047.          else
  1048.             Result := lpbi;
  1049.       finally
  1050.          if (OldPal <> 0) then SelectPalette(DC, OldPal, False);
  1051.          ReleaseDC(Focus,DC);
  1052.       end;
  1053.    end;
  1054. end;
  1056. (************************************************************************)
  1057. procedure DIB_DIBToBitmap(pbi: PDIB; var Bitmap: HBitmap; var Pal: HPalette);
  1058. var
  1059.   Focus: HWND;
  1060.   DC: HDC;
  1061.   OldPal: HPALETTE;
  1063. begin
  1064.    OldPal := 0;
  1065.    { we use the handle of the window with the focus (which, if this }
  1066.    { routine is called from a menu command, will be this window) in }
  1067.    { order to guarantee that the realized palette will have first   }
  1068.    { priority on the system palette                                 }
  1069.    Focus := GetFocus;
  1070.    DC := GetDC(Focus);
  1071.    try
  1072.       Pal := DIB_CreatePalette(pbi);
  1073.       if Pal <> 0 then
  1074.       begin
  1075.          OldPal := SelectPalette(DC, Pal, False);
  1076.          RealizePalette(DC);
  1077.       end;
  1079.       Bitmap := CreateDIBitmap(DC, pbi^,  CBM_INIT, DIB_PTR(pbi),
  1080.                                PBitmapInfo(pbi)^, DIB_RGB_COLORS);
  1081.    finally
  1082.       if (OldPal <> 0) then SelectPalette(DC, OldPal, False);
  1083.       ReleaseDC(Focus, DC);
  1084.    end;
  1085. end;
  1087. (************************************************************************)
  1088. function LoadPalette(FName: string): PLOGPALETTE;
  1089. Label ERROR_OPEN;
  1090. var
  1091.    {$IFDEF WIN32}
  1092.    hmio   : HMMIO;
  1093.    {$ELSE}
  1094.    hmio   : THMMIO;
  1095.    {$ENDIF}
  1096.    ckFile : TMMCKINFO;
  1097.    ckChunk: TMMCKINFO;
  1098.    iSize  : integer;
  1099.    iColors: integer;
  1100.    pData  : Pointer;
  1101.    pLogPal: PLOGPALETTE;
  1102.    aBuf   : array[0..MAX_PATH] of Char;
  1104. begin
  1105.    Result := nil;
  1106.    hmio   := 0;
  1107.    pData  := nil;
  1108.    if (FName <> '') then
  1109.    begin
  1110.       StrPCopy(aBuf,FName);
  1111.       hmio := mmioOpen(aBuf, nil, MMIO_READ OR MMIO_ALLOCBUF);
  1112.       if (hmio = 0) then
  1113.           goto ERROR_OPEN;
  1115.       { Check it's a RIFF PAL file }
  1116.       ckFile.fccType := $204C4150; {'P','A','L',' '};
  1117.       if (mmioDescend(hmio, @ckFile, nil, MMIO_FINDRIFF) <> 0) then
  1118.           goto ERROR_OPEN;
  1120.       { Find the 'data' chunk }
  1121.       ckChunk.ckid := $61746164; {'d','a','t','a'};
  1122.       if (mmioDescend(hmio, @ckChunk, @ckFile, MMIO_FINDCHUNK) <> 0) then
  1123.           goto ERROR_OPEN;
  1125.       { allocate some memory for the data chunk }
  1126.       iSize := ckChunk.cksize;
  1128.       pData := GlobalAllocMem(iSize);
  1129.       if (pdata = nil) then
  1130.           goto ERROR_OPEN;
  1132.       { read the data chunk }
  1133.       if (mmioRead(hmio, pdata, iSize) <> iSize) then
  1134.           goto ERROR_OPEN;
  1136.       { The data chunk should be a LOGPALETTE structure }
  1137.       { which we can create a palette from              }
  1139.       pLogPal := Pointer(pdata);
  1140.       if (pLogPal^.palVersion <> $300) then
  1141.           goto ERROR_OPEN;
  1143.       { Get the number of entries }
  1144.       iColors := pLogPal^.palNumEntries;
  1145.       if (iColors <= 0) then
  1146.          goto ERROR_OPEN;
  1148.       Result := pLogPal;
  1149.    end;
  1151. ERROR_OPEN:
  1153.    if (hmio <> 0) then
  1154.        mmioClose(hmio,0);
  1155.    if (Result = nil) and (pData <> nil) then
  1156.        GlobalFreePtr(pData);
  1157. end;
  1159. (************************************************************************)
  1160. function SavePalette(FName: string; pLogPal: PLOGPALETTE): Boolean;
  1161. Label ERROR_SAVE;
  1162. var
  1163.    {$IFDEF WIN32}
  1164.    hmio  : HMMIO;
  1165.    {$ELSE}
  1166.    hmio  : THMMIO;
  1167.    {$ENDIF}
  1168.    ckFile: TMMCKINFO;
  1169.    ckData: TMMCKINFO;
  1170.    iSize : integer;
  1171.    aBuf  : array[0..MAX_PATH] of Char;
  1173. begin
  1174.    Result := False;
  1176.    hmio   := 0;
  1178.    if pLogPal^.palNumEntries <= 0 then
  1179.       goto ERROR_SAVE;
  1181.    StrPCopy(aBuf,FName);
  1182.    hmio := mmioOpen(aBuf, nil, MMIO_WRITE or MMIO_CREATE or MMIO_ALLOCBUF);
  1183.    if (hmio = 0) then
  1184.        goto ERROR_SAVE;
  1186.    { Create a RIFF chunk for a PAL file }
  1187.    ckFile.cksize := 0; { corrected later }
  1188.    ckFile.fccType := $204C4150; {'P','A','L',' '};
  1189.    if (mmioCreateChunk(hmio, @ckFile, MMIO_CREATERIFF) <> 0) then
  1190.        goto ERROR_SAVE;
  1192.    iSize := sizeOf(TLogPalette)+sizeOf(TPaletteEntry)*pLogPal^.palNumEntries;
  1194.    { create the data chunk }
  1195.    ckData.cksize := iSize;
  1196.    ckData.ckid := $61746164; {'d','a','t','a'};
  1197.    if (mmioCreateChunk(hmio, @ckData, 0) <> 0) then
  1198.       goto ERROR_SAVE;
  1200.    { write the data chunk }
  1201.    if (mmioWrite(hmio, PChar(pLogPal), iSize) <> iSize) then
  1202.       goto ERROR_SAVE;
  1204.    { Ascend from the data chunk which will correct the length }
  1205.    mmioAscend(hmio, @ckData, 0);
  1206.    { Ascend from the RIFF/PAL chunk }
  1207.    mmioAscend(hmio, @ckFile, 0);
  1209.    Result := True;
  1211. ERROR_SAVE:
  1213.    if (hmio <> 0) then
  1214.        mmioClose(hmio, 0);
  1215. end;
  1217. end.