Ikoner + Listbox

Tegne et ikon i listbox\'en med OwnerDraw

du tager en form. Giver den et OnCreateEvent, og et OnShowEvent. Så sætter du en list box på den og giver ListBoxen et onDrawItemEvent. Så skriver du det følgende kode :


unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TForm1 = class(TForm)
    ListBox1: TListBox;
    procedure FormCreate(Sender: TObject);
    procedure ListBox1DrawItem(Control: TWinControl; Index: Integer;      Rect: TRect; State: TOwnerDrawState);
    procedure FormShow(Sender: TObject);
  private
    Number : Integer;
    ICons : array of HICON;
  public
    { Public declarations }
  end;

  TDriveType = (dtUnknown, dtNoDrive, dtFloppy, dtFixed, dtNetwork, dtCDROM, dtRAM);

var
  Form1: TForm1;

implementation

{$R *.DFM}
uses
  ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
begin
  Number := 0;
  ListBox1.Style := lbOwnerDrawFixed;
end;

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;  Rect: TRect; State: TOwnerDrawState);
var
  h: HIcon;
begin
  with (control as TListBox) do
  begin
    Canvas.Brush.Style:=bsSolid;
    Canvas.Brush.Color:=Color;

    if odSelected in State then
      Canvas.Brush.color:=clActiveCaption;

    Canvas.Fillrect(rect);
    Canvas.Textout( Rect.Left+20,Rect.Top,Items[Index]);
    h:= Icons[Index];

    if h<>0 then
      DrawIconEx(Canvas.Handle,Rect.left+1,rect.top+1,h,16,16,0,0,di_normal);

    if odFocused in state then
      canvas.DrawFocusRect(rect);
  end;
end;

Function GetSystemDirectory : String;
begin
  SetLength(Result, MAX_PATH);
  Windows.GetSystemDirectory(PChar(Result),MAX_PATH);
  SetLength(Result, Pred(Pos(#0,Result)));
end;

function VolumeID(DriveChar: Char): string;
var
  OldErrorMode: Integer;
  NotUsed, VolFlags: Cardinal;
  Buf: array [0..MAX_PATH] of Char;
begin
  OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS);
  try
    if GetVolumeInformation(PChar(DriveChar + \':\\\'), Buf, sizeof(Buf),
      nil, NotUsed, VolFlags, nil, 0) then
      SetString(Result, Buf, StrLen(Buf))
    else Result := \'\';
    if DriveChar < \'a\' then
      Result := AnsiUpperCaseFileName(Result)
    else
      Result := AnsiLowerCaseFileName(Result);
    Result := Format(\'%s\',[Result]);
  finally
    SetErrorMode(OldErrorMode);
  end;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  DriveNum: Integer;
  DriveChar: Char;
  DriveType: TDriveType;
  DriveBits: set of 0..25;
  Current : Integer;

  procedure AddDrive(const VolName: string);
  begin
  case DriveType of
    dtFloppy :
      Icons[Current] := ExtractIcon (Handle, PChar(GetSystemDirectory+\'\\Shell32.dll\'),6);
    dtFixed :
      Icons[Current] := ExtractIcon (Handle, PChar(GetSystemDirectory+\'\\Shell32.dll\'),8);
    dtNetwork :
      Icons[Current] := ExtractIcon (Handle, PChar(GetSystemDirectory+\'\\Shell32.dll\'),9);
    dtCDROM :
      Icons[Current] := ExtractIcon (Handle, PChar(GetSystemDirectory+\'\\Shell32.dll\'),11);
    dtRAM :
      Icons[Current] := ExtractIcon (Handle, PChar(GetSystemDirectory+\'\\Shell32.dll\'),12);
    end;
    inc(Current);
    ListBox1.Items.Add(Format(\'%s: %s\',[DriveChar, VolName]));
  end;

begin
  ListBox1.Clear;
  Integer(DriveBits) := GetLogicalDrives;
  for DriveNum := 0 to 25 do
  begin
    if not (DriveNum in DriveBits) then
      Continue;

    DriveChar := Char(DriveNum + Ord(\'a\'));
    DriveType := TDriveType(GetDriveType(PChar(DriveChar + \':\\\')));
    inc(Number);
  end;
  SetLength(Icons,Number);
  Current := 0;

  for DriveNum := 0 to 25 do
  begin
    if not (DriveNum in DriveBits) then
      Continue;

    DriveChar := Char(DriveNum + Ord(\'a\'));
    DriveType := TDriveType(GetDriveType(PChar(DriveChar + \':\\\')));
    DriveChar := Upcase(DriveChar);

    Adddrive(VolumeID(DriveChar))
  end;

  ListBox1.ItemIndex := 1;
end;

end.


Alternativt kunne du havde fundet koden på http://borrisholt.com

Jens B

Hov en lille fejl
AddDrive(9 skal se sådan her ud :

  procedure AddDrive(const VolName: string);
  begin
    case DriveType of
      dtFloppy:
        Icons[Current] := ExtractIcon(Handle, PChar(GetSystemDirectory + \'\\Shell32.dll\'), 6 + Integer(DriveNum > 2));
      dtFixed:
        Icons[Current] := ExtractIcon(Handle, PChar(GetSystemDirectory + \'\\Shell32.dll\'), 8);
      dtNetwork:
        Icons[Current] := ExtractIcon(Handle, PChar(GetSystemDirectory + \'\\Shell32.dll\'), 9);
      dtCDROM:
        Icons[Current] := ExtractIcon(Handle, PChar(GetSystemDirectory + \'\\Shell32.dll\'), 11);
      dtRAM:
        Icons[Current] := ExtractIcon(Handle, PChar(GetSystemDirectory + \'\\Shell32.dll\'), 12);
    end;

    inc(Current);
    ListBox1.Items.Add(Format(\'%s: %s\',[DriveChar, VolName]));
  end;

En passende øvelse for dig ville være at forklare den måbende hob forskellen .....

Jens B

borrisholt: Jeg har point til dig hvis du kan fortælle mig hvordan jeg graver ikonet for eks. en gif fil frem... Ikke fra filen men fra .gif associationen??

hvordan man graver der frem direkte fra .gif associationen ved jeg ikke men det her er lige så godt :

(Et lille hack)

uses
  ShellApi;

Function GetTempPath : String;
begin
  SetLength(Result, MAX_PATH);
  Windows.GetTempPath(MAX_PATH, PChar(Result));
  SetLength(Result, Pred(Pos(#0,Result)));
end;

procedure MakeBlankFile(const Name: string);
var
  tf: textfile;
  path: string;
begin
  path := ExtractFilePath(Name);
  AssignFile(tf,Name);
  ReWrite(tf);
  CloseFile(tf);
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  FileName : TFileName;
  Dummy : Word;
begin
  FileName := GetTempPath+\'tmp.gif\';
  MakeBlankFile(FileName);
  Image1.Picture.Icon.Handle := ExtractAssociatedIcon(hInstance,pointer(FileName),Dummy);
  DeleteFile(FileName);
end;

Jens B

Dumt spørgsmål: Jeg vil gerne ende med at ha\' en 16x16 bitmap og metoden giver en 32x32 icon.

Jeg føler mig ude på dybt vand :-)

Ja koden er næsten godt nok.
Jag man ikke lave den sådan at den ikke går ud og læser på A:, men den skal stadig finde ud afn om der findes et a: og b: Drev.
Og så har jeg fundet ud af at jeg gerne vil have det ud i en listview, med Volume navn, og i den anden col. og det er en CD, Harddisk, eller en 3,5 diskette.

Kan i finde ud af det?
PS. Og gerne et eksemplen.

Er der ikke nogen der kan finde ud af det????

dl >> Skal du havde ALT på et sølvfad ?

Ja, helst...

i dette sp.