home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 June / Chip_2002-06_cd1.bin / zkuste / delphi / kolekce / d6 / rxlibsetup.exe / {app} / units / CLIPICON.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  2002-02-19  |  12.5 KB  |  488 lines
  1. {*******************************************************}
  2. {                                                       }
  3. {         Delphi VCL Extensions (RX)                    }
  4. {                                                       }
  5. {         Copyright (c) 2001,2002 SGB Software          }
  6. {         Copyright (c) 1997, 1998 Fedor Koshevnikov,   }
  7. {                        Igor Pavluk and Serge Korolev  }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11.  
  12.  
  13. unit ClipIcon;
  14.  
  15. {$I RX.INC}
  16. {$P+,W-,R-}
  17.  
  18. interface
  19.  
  20. uses {$IFDEF WIN32} Windows, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  21.   SysUtils, Classes, Graphics, Controls;
  22.  
  23. { Icon clipboard routines }
  24.  
  25. var
  26.   CF_ICON: Word;
  27.  
  28. procedure CopyIconToClipboard(Icon: TIcon; BackColor: TColor);
  29. procedure AssignClipboardIcon(Icon: TIcon);
  30. function CreateIconFromClipboard: TIcon;
  31.  
  32. { Real-size icons support routines (32-bit only) }
  33.  
  34. procedure GetIconSize(Icon: HIcon; var W, H: Integer);
  35. function CreateRealSizeIcon(Icon: TIcon): HIcon;
  36. procedure DrawRealSizeIcon(Canvas: TCanvas; Icon: TIcon; X, Y: Integer);
  37.  
  38. implementation
  39.  
  40. uses Consts, Clipbrd, VCLUtils;
  41.  
  42. { Icon clipboard routines }
  43.  
  44. function CreateBitmapFromIcon(Icon: TIcon; BackColor: TColor): TBitmap;
  45. {$IFDEF WIN32}
  46. var
  47.   Ico: HIcon;
  48.   W, H: Integer;
  49. begin
  50.   Ico := CreateRealSizeIcon(Icon);
  51.   try
  52.     GetIconSize(Ico, W, H);
  53.     Result := TBitmap.Create;
  54.     try
  55.       Result.Width := W; Result.Height := H;
  56.       with Result.Canvas do begin
  57.         Brush.Color := BackColor;
  58.         FillRect(Rect(0, 0, W, H));
  59.         DrawIconEx(Handle, 0, 0, Ico, W, H, 0, 0, DI_NORMAL);
  60.       end;
  61.     except
  62.       Result.Free;
  63.       raise;
  64.     end;
  65.   finally
  66.     DestroyIcon(Ico);
  67.   end;
  68. {$ELSE}
  69. begin
  70.   Result := VclUtils.CreateBitmapFromIcon(Icon, BackColor);
  71. {$ENDIF}
  72. end;
  73.  
  74. procedure CopyIconToClipboard(Icon: TIcon; BackColor: TColor);
  75. var
  76.   Bmp: TBitmap;
  77.   Stream: TStream;
  78.   Data: THandle;
  79.   Format: Word;
  80.   Palette: HPalette;
  81.   Buffer: Pointer;
  82. begin
  83.   Bmp := CreateBitmapFromIcon(Icon, BackColor);
  84.   try
  85.     Stream := TMemoryStream.Create;
  86.     try
  87.       Icon.SaveToStream(Stream);
  88.       Palette := 0;
  89.       with Clipboard do begin
  90.         Open;
  91.         try
  92.           Clear;
  93.           Bmp.SaveToClipboardFormat(Format, Data, Palette);
  94.           SetClipboardData(Format, Data);
  95.           if Palette <> 0 then SetClipboardData(CF_PALETTE, Palette);
  96.           Data := GlobalAlloc(HeapAllocFlags, Stream.Size);
  97.           try
  98.             if Data <> 0 then begin
  99.               Buffer := GlobalLock(Data);
  100.               try
  101.                 Stream.Seek(0, 0);
  102.                 Stream.Read(Buffer^, Stream.Size);
  103.                 SetClipboardData(CF_ICON, Data);
  104.               finally
  105.                 GlobalUnlock(Data);
  106.               end;
  107.             end;
  108.           except
  109.             GlobalFree(Data);
  110.             raise;
  111.           end;
  112.         finally
  113.           Close;
  114.         end;
  115.       end;
  116.     finally
  117.       Stream.Free;
  118.     end;
  119.   finally
  120.     Bmp.Free;
  121.   end;
  122. end;
  123.  
  124. procedure AssignClipboardIcon(Icon: TIcon);
  125. var
  126.   Stream: TStream;
  127.   Data: THandle;
  128.   Buffer: Pointer;
  129. begin
  130.   if not Clipboard.HasFormat(CF_ICON) then Exit;
  131.   with Clipboard do begin
  132.     Open;
  133.     try
  134.       Data := GetClipboardData(CF_ICON);
  135.       Buffer := GlobalLock(Data);
  136.       try
  137.         Stream := TMemoryStream.Create;
  138.         try
  139.           Stream.Write(Buffer^, GlobalSize(Data));
  140.           Stream.Seek(0, 0);
  141.           Icon.LoadFromStream(Stream);
  142.         finally
  143.           Stream.Free;
  144.         end;
  145.       finally
  146.         GlobalUnlock(Data);
  147.       end;
  148.     finally
  149.       Close;
  150.     end;
  151.   end;
  152. end;
  153.  
  154. function CreateIconFromClipboard: TIcon;
  155. begin
  156.   Result := nil;
  157.   if not Clipboard.HasFormat(CF_ICON) then Exit;
  158.   Result := TIcon.Create;
  159.   try
  160.     AssignClipboardIcon(Result);
  161.   except
  162.     Result.Free;
  163.     raise;
  164.   end;
  165. end;
  166.  
  167. { Real-size icons support routines }
  168.  
  169. const
  170.   rc3_StockIcon = 0;
  171.   rc3_Icon = 1;
  172.   rc3_Cursor = 2;
  173.  
  174. type
  175.   PCursorOrIcon = ^TCursorOrIcon;
  176.   TCursorOrIcon = packed record
  177.     Reserved: Word;
  178.     wType: Word;
  179.     Count: Word;
  180.   end;
  181.  
  182.   PIconRec = ^TIconRec;
  183.   TIconRec = packed record
  184.     Width: Byte;
  185.     Height: Byte;
  186.     Colors: Word;
  187.     Reserved1: Word;
  188.     Reserved2: Word;
  189.     DIBSize: Longint;
  190.     DIBOffset: Longint;
  191.   end;
  192.  
  193. procedure OutOfResources; near;
  194. begin
  195.   raise EOutOfResources.Create(ResStr(SOutOfResources));
  196. end;
  197.  
  198. {$IFDEF WIN32}
  199.  
  200. function WidthBytes(I: Longint): Longint;
  201. begin
  202.   Result := ((I + 31) div 32) * 4;
  203. end;
  204.  
  205. function GetDInColors(BitCount: Word): Integer;
  206. begin
  207.   case BitCount of
  208.     1, 4, 8: Result := 1 shl BitCount;
  209.     else Result := 0;
  210.   end;
  211. end;
  212.  
  213. function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
  214. var
  215.   DC, Mem1, Mem2: HDC;
  216.   Old1, Old2: HBITMAP;
  217.   Bitmap: Windows.TBitmap;
  218. begin
  219.   Mem1 := CreateCompatibleDC(0);
  220.   Mem2 := CreateCompatibleDC(0);
  221.   GetObject(Src, SizeOf(Bitmap), @Bitmap);
  222.   if Mono then
  223.     Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
  224.   else begin
  225.     DC := GetDC(0);
  226.     if DC = 0 then OutOfResources;
  227.     try
  228.       Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
  229.       if Result = 0 then OutOfResources;
  230.     finally
  231.       ReleaseDC(0, DC);
  232.     end;
  233.   end;
  234.   if Result <> 0 then begin
  235.     Old1 := SelectObject(Mem1, Src);
  236.     Old2 := SelectObject(Mem2, Result);
  237.     StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
  238.       Bitmap.bmHeight, SrcCopy);
  239.     if Old1 <> 0 then SelectObject(Mem1, Old1);
  240.     if Old2 <> 0 then SelectObject(Mem2, Old2);
  241.   end;
  242.   DeleteDC(Mem1);
  243.   DeleteDC(Mem2);
  244. end;
  245.  
  246. procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP);
  247. type
  248.   PLongArray = ^TLongArray;
  249.   TLongArray = array[0..1] of Longint;
  250. var
  251.   Temp: HBITMAP;
  252.   NumColors: Integer;
  253.   DC: HDC;
  254.   Bits: Pointer;
  255.   Colors: PLongArray;
  256.   IconSize: TPoint;
  257.   BM: Windows.TBitmap;
  258. begin
  259.   IconSize.X := GetSystemMetrics(SM_CXICON);
  260.   IconSize.Y := GetSystemMetrics(SM_CYICON);
  261.   with BI do begin
  262.     biHeight := biHeight shr 1; { Size in record is doubled }
  263.     biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;
  264.     NumColors := GetDInColors(biBitCount);
  265.   end;
  266.   DC := GetDC(0);
  267.   if DC = 0 then OutOfResources;
  268.   try
  269.     Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
  270.     Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);
  271.     if Temp = 0 then OutOfResources;
  272.     try
  273.       GetObject(Temp, SizeOf(BM), @BM);
  274.       IconSize.X := BM.bmWidth;
  275.       IconSize.Y := BM.bmHeight;
  276.       XorBits := DupBits(Temp, IconSize, False);
  277.     finally
  278.       DeleteObject(Temp);
  279.     end;
  280.     with BI do begin
  281.       Inc(Longint(Bits), biSizeImage);
  282.       biBitCount := 1;
  283.       biSizeImage := WidthBytes(Longint(biWidth) * biBitCount) * biHeight;
  284.       biClrUsed := 2;
  285.       biClrImportant := 2;
  286.     end;
  287.     Colors := Pointer(Longint(@BI) + SizeOf(BI));
  288.     Colors^[0] := 0;
  289.     Colors^[1] := $FFFFFF;
  290.     Temp := CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS);
  291.     if Temp = 0 then OutOfResources;
  292.     try
  293.       AndBits := DupBits(Temp, IconSize, True);
  294.     finally
  295.       DeleteObject(Temp);
  296.     end;
  297.   finally
  298.     ReleaseDC(0, DC);
  299.   end;
  300. end;
  301.  
  302. procedure ReadIcon(Stream: TStream; var Icon: HICON; ImageCount: Integer;
  303.   StartOffset: Integer);
  304. type
  305.   PIconRecArray = ^TIconRecArray;
  306.   TIconRecArray = array[0..300] of TIconRec;
  307. var
  308.   List: PIconRecArray;
  309.   HeaderLen, Length: Integer;
  310.   Colors, BitsPerPixel: Word;
  311.   C1, C2, N, Index: Integer;
  312.   IconSize: TPoint;
  313.   DC: HDC;
  314.   BI: PBitmapInfoHeader;
  315.   ResData: Pointer;
  316.   XorBits, AndBits: HBITMAP;
  317.   XorInfo, AndInfo: Windows.TBitmap;
  318.   XorMem, AndMem: Pointer;
  319.   XorLen, AndLen: Integer;
  320. begin
  321.   HeaderLen := SizeOf(TIconRec) * ImageCount;
  322.   List := AllocMem(HeaderLen);
  323.   try
  324.     Stream.Read(List^, HeaderLen);
  325.     IconSize.X := GetSystemMetrics(SM_CXICON);
  326.     IconSize.Y := GetSystemMetrics(SM_CYICON);
  327.     DC := GetDC(0);
  328.     if DC = 0 then OutOfResources;
  329.     try
  330.       BitsPerPixel := GetDeviceCaps(DC, PLANES) * GetDeviceCaps(DC, BITSPIXEL);
  331.       if BitsPerPixel = 24 then Colors := 0
  332.       else Colors := 1 shl BitsPerPixel;
  333.     finally
  334.       ReleaseDC(0, DC);
  335.     end;
  336.     Index := -1;
  337.     { the following code determines which image most closely matches the
  338.       current device. It is not meant to absolutely match Windows
  339.       (known broken) algorithm }
  340.     C2 := 0;
  341.     for N := 0 to ImageCount - 1 do begin
  342.       C1 := List^[N].Colors;
  343.       if C1 = Colors then begin
  344.         Index := N;
  345.         Break;
  346.       end
  347.       else if Index = -1 then begin
  348.         if C1 <= Colors then begin
  349.           Index := N;
  350.           C2 := List^[N].Colors;
  351.         end;
  352.       end
  353.       else if C1 > C2 then Index := N;
  354.     end;
  355.     if Index = -1 then Index := 0;
  356.     with List^[Index] do begin
  357.       BI := AllocMem(DIBSize);
  358.       try
  359.         Stream.Seek(DIBOffset  - (HeaderLen + StartOffset), 1);
  360.         Stream.Read(BI^, DIBSize);
  361.         TwoBitsFromDIB(BI^, XorBits, AndBits);
  362.         GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
  363.         GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
  364.         IconSize.X := AndInfo.bmWidth;
  365.         IconSize.Y := AndInfo.bmHeight;
  366.         with AndInfo do
  367.           AndLen := bmWidthBytes * bmHeight * bmPlanes;
  368.         with XorInfo do
  369.           XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
  370.         Length := AndLen + XorLen;
  371.         ResData := AllocMem(Length);
  372.         try
  373.           AndMem := ResData;
  374.           with AndInfo do
  375.             XorMem := Pointer(Longint(ResData) + AndLen);
  376.           GetBitmapBits(AndBits, AndLen, AndMem);
  377.           GetBitmapBits(XorBits, XorLen, XorMem);
  378.           DeleteObject(XorBits);
  379.           DeleteObject(AndBits);
  380.           Icon := CreateIcon(HInstance, IconSize.X, IconSize.Y,
  381.             XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
  382.           if Icon = 0 then OutOfResources;
  383.         finally
  384.           FreeMem(ResData, Length);
  385.         end;
  386.       finally
  387.         FreeMem(BI, DIBSize);
  388.       end;
  389.     end;
  390.   finally
  391.     FreeMem(List, HeaderLen);
  392.   end;
  393. end;
  394.  
  395. procedure GetIconSize(Icon: HIcon; var W, H: Integer);
  396. var
  397.   IconInfo: TIconInfo;
  398.   BM: Windows.TBitmap;
  399. begin
  400.   if GetIconInfo(Icon, IconInfo) then begin
  401.     try
  402.       if IconInfo.hbmColor <> 0 then begin
  403.         GetObject(IconInfo.hbmColor, SizeOf(BM), @BM);
  404.         W := BM.bmWidth;
  405.         H := BM.bmHeight;
  406.       end
  407.       else if IconInfo.hbmMask <> 0 then begin { Monochrome icon }
  408.         GetObject(IconInfo.hbmMask, SizeOf(BM), @BM);
  409.         W := BM.bmWidth;
  410.         H := BM.bmHeight shr 1; { Size in record is doubled }
  411.       end
  412.       else begin
  413.         W := GetSystemMetrics(SM_CXICON);
  414.         H := GetSystemMetrics(SM_CYICON);
  415.       end;
  416.     finally
  417.       if IconInfo.hbmColor <> 0 then DeleteObject(IconInfo.hbmColor);
  418.       if IconInfo.hbmMask <> 0 then DeleteObject(IconInfo.hbmMask);
  419.     end;
  420.   end
  421.   else begin
  422.     W := GetSystemMetrics(SM_CXICON);
  423.     H := GetSystemMetrics(SM_CYICON);
  424.   end;
  425. end;
  426.  
  427. {$ELSE}
  428.  
  429. procedure GetIconSize(Icon: HICON; var W, H: Integer);
  430. begin
  431.   W := GetSystemMetrics(SM_CXICON);
  432.   H := GetSystemMetrics(SM_CYICON);
  433. end;
  434.  
  435. {$ENDIF WIN32}
  436.  
  437. function CreateRealSizeIcon(Icon: TIcon): HIcon;
  438. {$IFDEF WIN32}
  439. var
  440.   Mem: TMemoryStream;
  441.   CI: TCursorOrIcon;
  442. begin
  443.   Result := 0;
  444.   Mem := TMemoryStream.Create;
  445.   try
  446.     Icon.SaveToStream(Mem);
  447.     Mem.Position := 0;
  448.     Mem.ReadBuffer(CI, SizeOf(CI));
  449.     case CI.wType of
  450.       RC3_STOCKICON: Result := LoadIcon(0, IDI_APPLICATION);
  451.       RC3_ICON: ReadIcon(Mem, Result, CI.Count, SizeOf(CI));
  452.       else Result := CopyIcon(Icon.Handle);
  453.     end;
  454.   finally
  455.     Mem.Free;
  456.   end;
  457. {$ELSE}
  458. begin
  459.   Result := CopyIcon(hInstance, Icon.Handle);
  460. {$ENDIF}
  461. end;
  462.  
  463. procedure DrawRealSizeIcon(Canvas: TCanvas; Icon: TIcon; X, Y: Integer);
  464. {$IFDEF WIN32}
  465. var
  466.   Ico: HIcon;
  467.   W, H: Integer;
  468. begin
  469.   Ico := CreateRealSizeIcon(Icon);
  470.   try
  471.     GetIconSize(Ico, W, H);
  472.     DrawIconEx(Canvas.Handle, X, Y, Ico, W, H, 0, 0, DI_NORMAL);
  473.   finally
  474.     DestroyIcon(Ico);
  475.   end;
  476. {$ELSE}
  477. begin
  478.   Canvas.Draw(X, Y, Icon);
  479. {$ENDIF}
  480. end;
  481.  
  482. { Module initialization part }
  483.  
  484. initialization
  485.   { The following string should not be localized }
  486.   CF_ICON := RegisterClipboardFormat('Delphi Icon');
  487.   TPicture.RegisterClipboardFormat(CF_ICON, TIcon);
  488. end.