Текущий архив: 2006.11.19;
Скачать: CL | DM;

Вниз

Использование иконок различного размера   Найти похожие ветки 

← →
Icon   (2006-10-03 15:03) [0]

Есть файл ico содержащий несколько иконок от 16x16 до 128x128. Есть ли возможность отобразить это дело в TImage, например? Установка Image.Picture.Icon.(Width/Height) не помогает.

---

← →
Ketmar ©   (2006-10-03 15:11) [1]

DrawIcon()?

---

← →
clickmaker ©   (2006-10-03 15:26) [2]

DrawIconEx

---

← →
Icon   (2006-10-03 15:28) [3]

2 Ketmar

Наверное действительно придётся в API лезть. Я думал, может средствами VCL можно сделать, просто я не догоняю чего-то.

---

← →
Icon   (2006-10-03 15:30) [4]

Ясно. Спасибо всем. В общем я примерно так и думал. Халявы захотелось :)

---

← →
Ketmar ©   (2006-10-03 15:33) [5]

>[2] clickmaker(c) 3-Oct-2006, 15:26
>DrawIconEx
оно там рядом. сути это не меняет. %-)

---

← →
Rouse_ ©   (2006-10-04 09:14) [6]

uses
 Consts, RTLConsts;

var
 FIconDir: TCursorOrIcon;
 FIconDirectoryEntry: array of TIconDirectoryEntry;
 FCustomIcon: HBITMAP;

procedure OutOfResources;
begin
 raise EOutOfResources.Create(SOutOfResources);
end;

procedure GDIError;
var
 ErrorCode: Integer;
 Buf: array [Byte] of Char;
begin
 ErrorCode := GetLastError;
 if (ErrorCode <> 0) and (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, nil,
   ErrorCode, LOCALE_USER_DEFAULT, Buf, sizeof(Buf), nil) <> 0) then
   raise EOutOfResources.Create(Buf)
 else
   OutOfResources;
end;

procedure TwoBitsFromDIB(var BI: TBitmapInfoHeader; var XorBits, AndBits: HBITMAP;
 const IconSize: TPoint);

 function GetDInColors(BitCount: Word): Integer;
 begin
   case BitCount of
     1, 4, 8: Result := 1 shl BitCount;
   else
     Result := 0;
   end;
 end;

 function GDICheck(Value: Integer): Integer;
 begin
   if Value = 0 then GDIError;
   Result := Value;
 end;

 function DupBits(Src: HBITMAP; Size: TPoint; Mono: Boolean): HBITMAP;
 var
   DC, Mem1, Mem2: HDC;
   Old1, Old2: HBITMAP;
   Bitmap: Windows.TBitmap;
 begin
   Mem1 := CreateCompatibleDC(0);
   Mem2 := CreateCompatibleDC(0);

   try
     GetObject(Src, SizeOf(Bitmap), @Bitmap);
     if Mono then
       Result := CreateBitmap(Size.X, Size.Y, 1, 1, nil)
     else
     begin
       DC := GetDC(0);
       if DC = 0 then GDIError;
       try
         Result := CreateCompatibleBitmap(DC, Size.X, Size.Y);
         if Result = 0 then GDIError;
       finally
         ReleaseDC(0, DC);
       end;
     end;

     if Result <> 0 then
     begin
       Old1 := SelectObject(Mem1, Src);
       Old2 := SelectObject(Mem2, Result);

       StretchBlt(Mem2, 0, 0, Size.X, Size.Y, Mem1, 0, 0, Bitmap.bmWidth,
         Bitmap.bmHeight, SrcCopy);
       if Old1 <> 0 then SelectObject(Mem1, Old1);
       if Old2 <> 0 then SelectObject(Mem2, Old2);
     end;
   finally
     DeleteDC(Mem1);
     DeleteDC(Mem2);
   end;
 end;

type
 PLongArray = ^TLongArray;
 TLongArray = array[0..1] of Longint;
var
 Temp: HBITMAP;
 NumColors: Integer;
 DC: HDC;
 Bits: Pointer;
 Colors: PLongArray;
begin
 with BI do
 begin
   biHeight := biHeight shr 1;
   biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
   NumColors := GetDInColors(biBitCount);
 end;
 DC := GetDC(0);
 if DC = 0 then OutOfResources;
 try
   Bits := Pointer(Longint(@BI) + SizeOf(BI) + NumColors * SizeOf(TRGBQuad));
   Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
   try
     XorBits := DupBits(Temp, IconSize, False);
   finally
     DeleteObject(Temp);
   end;
   with BI do
   begin
     Inc(Longint(Bits), biSizeImage);
     biBitCount := 1;
     biSizeImage := BytesPerScanline(biWidth, biBitCount, 32) * biHeight;
     biClrUsed := 2;
     biClrImportant := 2;
   end;
   Colors := Pointer(Longint(@BI) + SizeOf(BI));
   Colors^[0] := 0;
   Colors^[1] := $FFFFFF;
   Temp := GDICheck(CreateDIBitmap(DC, BI, CBM_INIT, Bits, PBitmapInfo(@BI)^, DIB_RGB_COLORS));
   try
     AndBits := DupBits(Temp, IconSize, True);
   finally
     DeleteObject(Temp);
   end;
 finally
   ReleaseDC(0, DC);
 end;
end;

function GetIcon(DIBData: Pointer; IconSize: TPoint): HICON;
var
 ResData: Pointer;
 XorBits, AndBits: HBITMAP;
 XorInfo, AndInfo: Windows.TBitmap;
 XorMem, AndMem: Pointer;
 XorLen, AndLen: Integer;
 Length: Integer;
begin
 TwoBitsFromDIB(PBitmapInfoHeader(DIBData)^, XorBits, AndBits, IconSize);
 GetObject(AndBits, SizeOf(Windows.TBitmap), @AndInfo);
 GetObject(XorBits, SizeOf(Windows.TBitmap), @XorInfo);
 with AndInfo do
   AndLen := bmWidthBytes * bmHeight * bmPlanes;
 with XorInfo do
   XorLen :=  bmWidthBytes * bmHeight * bmPlanes;
 Length := AndLen + XorLen;
 ResData := AllocMem(Length);
 try
   AndMem := ResData;
   with AndInfo do
     XorMem := Pointer(Longint(ResData) + AndLen);
   GetBitmapBits(AndBits, AndLen, AndMem);
   GetBitmapBits(XorBits, XorLen, XorMem);
   DeleteObject(XorBits);
   DeleteObject(AndBits);
   Result := CreateIcon(HInstance, IconSize.X, IconSize.Y,
     XorInfo.bmPlanes, XorInfo.bmBitsPixel, AndMem, XorMem);
   if Result = 0 then GDIError;
 finally
   FreeMem(ResData, Length);
 end;
end;

---

← →
Rouse_ ©   (2006-10-04 09:15) [7]

после чего:

procedure TForm21.Button2Click(Sender: TObject);
var
 Stream: TMemoryStream;
 I: Integer;
 ColorTable: array of Byte;
begin
 Stream := TMemoryStream.Create;
 try
   Image1.Picture.Icon.SaveToStream(Stream);
   Stream.Position := 0;
   Stream.Read(FIconDir, SizeOf(TCursorOrIcon));
   SetLength(FIconDirectoryEntry, FIconDir.Count);
   for I := 0 to FIconDir.Count - 1 do
   begin
     Stream.Read(FIconDirectoryEntry[I], SizeOf(TIconDirectoryEntry));
     Dec(FIconDirectoryEntry[I].bWidth, Byte(FIconDirectoryEntry[I].bWidth = 0));
     Dec(FIconDirectoryEntry[I].bHeight, Byte(FIconDirectoryEntry[I].bHeight = 0));
   end;

   for I := 0 to FIconDir.Count - 1 do
   begin
     Stream.Position := FIconDirectoryEntry[I].dwImageOffset;
     SetLength(ColorTable, FIconDirectoryEntry[I].dwBytesInRes);
     Stream.Read(ColorTable[0], FIconDirectoryEntry[I].dwBytesInRes);
     try
       FCustomIcon := GetIcon(@ColorTable[0],
         Point(FIconDirectoryEntry[I].bWidth, FIconDirectoryEntry[I].bHeight));
     except
       FCustomIcon := INVALID_HANDLE_VALUE;
     end;

     if FCustomIcon <> INVALID_HANDLE_VALUE then
       DrawIconEx(Canvas.Handle, (FIconDir.Count * 60) - (I * 60), 350, FCustomIcon,
         FIconDirectoryEntry[I].bWidth,
         FIconDirectoryEntry[I].bHeight, 0, 0, DI_NORMAL);
   end;
 finally
   Stream.Free;
 end;
end;

---

← →
Vovan#1   (2006-10-04 23:02) [8]


unit unitIconClass;

interface

uses Windows, Classes, Sysutils, Graphics, Dialogs;

type
 TDrawWhat = (dwCombined, dwXorMask, dwAndMask);

const
 PixelCountMax = 32768;

type pRGBTriple = ^TRGBTriple;
 TRGBTriple = packed record
   rgbtBlue: Byte;
   rgbtGreen: Byte;
   rgbtRed: Byte;
 end;

type pRGBQuad = ^TRGBQuad;
 TRGBQuad = packed record
   rgbBlue: Byte;
   rgbGreen: Byte;
   rgbRed: Byte;
   rgbReserved: Byte;
 end;

type
 pRGBTripleArray = ^TRGBTripleArray;
 TRGBTripleArray = array[0..PixelCountMax - 1] of TRGBTriple;
 pRGBQuadArray = ^TRGBQuadArray;
 TRGBQuadArray = array[0..PixelCountMax - 1] of TRGBQuad;

type
 TIconHeader = packed record
   idReserved: Word;
   idType: Word;
   idCount: Word;
 end;

 TIconDirEntry = packed record
   bWidth: Byte;
   bHeight: Byte;
   bColorCount: Byte;
   bReserved: Byte;
   wPlanes: Word;
   wBitCount: Word;
   dwBytesInRes: Longint;
   dwImageOffset: Longint;
 end;

type
 TIconClass = class
   Loaded: Boolean;
   CanvasHandle: HDC;
   IconHeader: TIconHeader;
   IconDirEntries: array of TIconDirEntry;
   IconXorBitmaps: array of TBitmap;
   IconAndBitmaps: array of TBitmap;
   procedure LoadFromIconFile(Filename: string);

   procedure Draw(x, y: Integer; Index: Integer;
     DrawWhat: TDrawWhat; Bitmap: TBitmap);

   destructor Destroy; override;
 end;

function BlendColors(const Color1, Color2: TColor; Amount: Extended): TColor;

implementation

destructor TIconClass.Destroy;
var i: Integer;
begin
 for i := Low(IconXorBitmaps) to High(IconXorBitmaps) do
   IconXorBitmaps[i].Free;
 for i := Low(IconAndBitmaps) to High(IconAndBitmaps) do
   IconAndBitmaps[i].Free;
 DeleteDC(CanvasHandle);
 inherited Destroy;
end;

procedure TIconClass.LoadFromIconFile(Filename: string);
var FS: TFileStream;
 ColorTable: array[0..0] of TRGBQuad;
 BitmapInfoHeader: TBitmapInfoHeader;
 BitmapInfo: TBitmapInfo;
 BitmapBits: Pointer;
 PalCount: Integer;
 IconPalette: PLogPalette;
 hIconPalette: HPALETTE;
 i, k: Integer;
 Ahdc: HDC;
begin
 if not FileExists(Filename) then Exit;

 FS := TFileStream.Create(Filename, fmOpenRead or fmShareExclusive);
 try
   FS.Read(IconHeader, SizeOf(TIconHeader));

   SetLength(IconDirEntries, IconHeader.idCount);
   for i := 1 to IconHeader.idCount do
     FS.Read(IconDirEntries[i - 1], SizeOf(TIconDirEntry));

   for i := Low(IconXorBitmaps) to High(IconXorBitmaps) do
     IconXorBitmaps[i].Free;
   SetLength(IconXorBitmaps, IconHeader.idCount);
   for i := Low(IconAndBitmaps) to High(IconAndBitmaps) do
     IconAndBitmaps[i].Free;
   SetLength(IconAndBitmaps, IconHeader.idCount);

   for i := 0 to IconHeader.idCount - 1 do
     begin
       FS.Seek(IconDirEntries[i].dwImageOffset, soFromBeginning);

       FS.Read(BitmapInfoHeader, SizeOf(TBitmapInfoHeader));

       BitmapInfoHeader.biHeight := BitmapInfoHeader.biHeight div 2;
       BitmapInfo.bmiHeader := BitmapInfoHeader;

       if (BitMapInfoHeader.biBitCount <= 8) then // !!!!!
         begin
           if IconDirEntries[i].bColorCount = 0 then
             PalCount := 256
           else
             PalCount := IconDirEntries[i].bColorCount;

           GetMem(IconPalette, SizeOf(TLogPalette)
             + SizeOf(TPaletteEntry) * PalCount);

           IconPalette.palVersion := $300;
           IconPalette.palNumEntries := PalCount;

           FS.Read(IconPalette.palPalEntry, SizeOf(TPaletteEntry) * PalCount);

           HIconPalette := CreatePalette(IconPalette^);
           FreeMem(IconPalette);
         end; // !!!!!

       IconXorBitmaps[i] := TBitmap.Create;

       IconXorBitmaps[i].Handle := CreateDIBSection(
         CanvasHandle, BitmapInfo, DIB_RGB_COLORS, BitmapBits, 0, 0);

        IconXorBitmaps[i].Canvas.Brush.Color := clRed;
        IconXorBitmaps[i].Canvas.FillRect(Rect(0, 0, 32, 32));

        BitBlt(CanvasHandle, 32, 32, 32, 32, IconXorBitmaps[i].Canvas.Handle,
          0, 0, SrcCopy);

       FS.Read(BitmapBits^, BitmapInfoHeader.biHeight *
         (BytesPerScanline(BitmapInfoHeader.biWidth,
         BitmapInfoHeader.biBitCount, 32)));

      If (HIconPalette <> 0) and (BitMapInfoHeader.biBitCount <= 8) // !!!!!
        then IconXorBitmaps[i].Palette := HIconPalette; // !!!!!

        BitBlt(CanvasHandle, 0, 0, 32, 32, IconXorBitmaps[i].Canvas.Handle,
          0, 0, SrcCopy);

       IconAndBitmaps[i] := TBitmap.Create;

       with BitmapInfoHeader do
         begin
           biSize := SizeOf(TBitmapInfoHeader);
           biPlanes := 1;
           biBitCount := 1;
           biCompression := BI_RGB;
           biSizeImage := 0;
           biXPelsPerMeter := 0;
           biYPelsPerMeter := 0;
           biClrUsed := 0;
           biClrImportant := 0;
         end;

       BitmapInfo.bmiHeader := BitmapInfoHeader;

       IconAndBitmaps[i].PixelFormat := pf1bit;

       IconAndBitmaps[i].Handle := CreateDIBSection(
         CanvasHandle, BitmapInfo, DIB_RGB_COLORS, BitmapBits, 0, 0);

       FS.Read(BitmapBits^, BitmapInfoHeader.biHeight *
         (BytesPerScanline(BitmapInfoHeader.biWidth,
         BitmapInfoHeader.biBitCount, 32)));

       for k := 0 to 1 do
         with ColorTable[k] do
           begin
             rgbBlue := k * 255;
             rgbGreen := k * 255;
             rgbRed := k * 255;
             rgbReserved := 0;
           end;

       SetDIBColorTable(IconAndBitmaps[i].Canvas.Handle, 0, 2, ColorTable);
     end;
 finally
   FS.Free;
 end;
 Loaded := True;
end;


...........

---

← →
Vovan#1   (2006-10-04 23:02) [9]


procedure TIconClass.Draw(x, y: Integer; Index: Integer;
 DrawWhat: TDrawWhat; Bitmap: TBitmap);
var x0, y0: Integer;
 TempColor: TColor;
 RowD: pRGBTripleArray; // D = Destination
 RowS: pRGBQuadArray; // S = Source
begin
 if DrawWhat = dwXorMask then
   begin
     with IconXorBitmaps[Index] do
       BitBlt(Bitmap.Canvas.Handle, x, y, Width, Height,
         Canvas.Handle, 0, 0, SrcCopy);
     Exit;
   end;
 if DrawWhat = dwAndMask then
   begin
     with IconAndBitmaps[Index] do
       BitBlt(Bitmap.Canvas.Handle, x, y, Width, Height,
         Canvas.Handle, 0, 0, SrcCopy);
     Exit;
   end;
 if IconXorBitmaps[Index].PixelFormat <> pf32bit then
   begin
     with IconAndBitmaps[Index] do
       BitBlt(Bitmap.Canvas.Handle, x, y, Width, Height,
         Canvas.Handle, 0, 0, SrcPaint);
     with IconXorBitmaps[Index] do
       BitBlt(Bitmap.Canvas.Handle, x, y, Width, Height,
         Canvas.Handle, 0, 0, SrcAnd);
   end
 else
   begin
     for y0 := y to y + IconXorBitmaps[Index].Height - 1 do
       begin
         RowD := Bitmap.Scanline[y0];
         RowS := IconXorBitmaps[Index].Scanline[y0 - y];
         for x0 := x to x + IconXorBitmaps[Index].Width - 1 do
           begin
             tempColor := BlendColors(TColor(RGB(RowD[x0].rgbtRed,
               RowD[x0].rgbtGreen, RowD[x0].rgbtBlue)),
               TColor(RGB(RowS[x0 - x].rgbRed, RowS[x0 - x].rgbGreen,
               RowS[x0 - x].rgbBlue)), RowS[x0 - x].rgbReserved / 256);
             with RowD[x0] do
               begin
                 rgbtRed := GetRValue(tempColor);
                 rgbtGreen := GetGValue(tempColor);
                 rgbtBlue := GetBValue(tempColor);
               end;
           end;
       end;
   end;
end;

function BlendColors(const Color1, Color2: TColor; Amount: Extended): TColor;
var
 R, R2, G, G2, B, B2: Integer;
 win1, win2: Integer;
begin
 win1 := ColorToRGB(Color1);
 win2 := ColorToRGB(Color2);
 R := GetRValue(win1); R2 := GetRValue(win2);
 G := GetGValue(win1); G2 := GetGValue(win2);
 B := GetBValue(win1); B2 := GetBValue(win2);
 B2 := Round((1 - Amount) * B + Amount * B2);
 G2 := Round((1 - Amount) * G + Amount * G2);
 R2 := Round((1 - Amount) * R + Amount * R2);
 if R2 < 0 then R2 := 0; if R2 > 255 then R2 := R;
 if G2 < 0 then G2 := 0; if G2 > 255 then G2 := R;
 if B2 < 0 then B2 := 0; if B2 > 255 then B2 := R;
 Result := TColor(RGB(R2, G2, B2));
end;

end.


---

← →
Германн ©   (2006-10-05 00:46) [10]

> Icon   (03.10.06 15:30) [4]
>
> Ясно. Спасибо всем. В общем я примерно так и думал. Халявы
> захотелось :)
>

Ну ты просто шаман! Стоило только захотеть и вон сколько всего сразу. И всё без пошлины! :-)

---

Страницы: 1 вся ветка

Текущий архив: 2006.11.19;
Скачать: CL | DM;

Наверх

Память: 0.52 MB
Время: 0.032 c