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