Listboxeintrag mit Link selberzeichnen

[Luckie]

Ich zeichne Listboxeinträge selber. Jetzt hatte ich die Idee, dass es schön wäre, wenn man einen Teil des Textes wie einen Link anklicken könnte. Speziell in meinem Fall handelt es sich um eine Adressdatenbank. In dem Listboxeintrag wird der Name und darunter die Telefonnummern ausgegeben. Jett wollte ich zusätzlich noch die E-mailadresse ausgeben und diese sollte anklickbar sein. Sie entsprechen formatiert auszugeben ist kein Problem. Nur müsste ich rausfinden, wann der Mauszeiger über über genau diesem Bereich ist, um den Mauszeiger anzupassen und um bei einem Klick eine Aktion auszulösen.

Hier mal meine bisherige Zeichenroutine:

Delphi-Quellcode:

procedure DrawItems(AControl: TWinControl; AIndex: Integer; ARect: TRect; AState: TOwnerDrawState);
const
  Col2: array[Boolean] of TColor = (clInactiveCaptionText, clWindowText);
var
  Ico: TIcon;
  ItemCaption: string;
  Nachname: string;
  Vorname: string;
  Firma: string;
  Tele1: string;
  Tele2: string;

begin
  Nachname := TContact((AControl as TListbox).Items.Objects[AIndex]).Name;
  Vorname := TContact((AControl as TListbox).Items.Objects[AIndex]).Vorname;
  Firma := TContact((AControl as TListbox).Items.Objects[AIndex]).Firma;
  Tele1 := FormatTelefonNumber(TContact((AControl as TListbox).Items.Objects[AIndex]).Telefon1);
  Tele2 := FormatTelefonNumber(TContact((AControl as TListbox).Items.Objects[AIndex]).Telefon2);

  ItemCaption := Helper.Makecaption(Nachname, Vorname, Firma);
  with (AControl as TListbox) do
  begin
    if odSelected in AState then
      Canvas.Font.Color := clCaptionText
    else
      Canvas.Font.Color := Col2[(AControl as TListbox).Enabled];

    Canvas.FillRect(ARect);

    // Grafik
    Ico := TIcon.Create;
    try
      if Firma <> '' then
        Main.frmAdressen.ImageList1.Draw(Canvas, ARect.left + 4, ARect.Top + 4, 10, dsTransparent, itImage)
      else
        Main.frmAdressen.ImageList1.Draw(Canvas, ARect.left + 4, ARect.Top + 4, 8, dsTransparent, itImage);
    finally
      Ico.Free;
    end;

    // Itemcaption
    Canvas.Font.Style := [fsBold];
    Canvas.Font.Size := 12;
    Canvas.Font.Name := 'Arial';
    Canvas.TextOut(ARect.Left + 25, ARect.Top + 3, ItemCaption);
    // SubText
    Canvas.Font.Style := [];
    Canvas.Font.Size := 10;

    ARect.Left := ARect.Left + 25;
    ARect.Top := ARect.Top + 2 + 19;
    // nur Telefon1
    if (Tele1 <> '') and (Tele2 = '') then
    begin
      DrawText(Canvas.Handle, PChar(Tele1), length(Tele1), ARect, DT_LEFT);
    end;
    // nur Telefon2
    if (Tele1 = '') and (Tele2 <> '') then
    begin
      DrawText(Canvas.Handle, PChar(Tele2), length(Tele2), ARect, DT_LEFT);
    end;
    // beides
    if (Tele1 <> '') and (Tele2 <> '') then
    begin
      DrawText(Canvas.Handle, PChar(Tele1), length(Tele1), ARect, DT_LEFT);
      ARect.Left := ARect.Left + 125;
      DrawText(Canvas.Handle, PChar(Tele2), length(Tele2), ARect, DT_LEFT);
    end;
  end;
end;

Im Anhang ein Blid, wie ich es mir vorstelle. Und nur die Mailadresse sollte eben anklickbar sein. Wenn möglich ohne Fremdkomponenten.

[jaenicke]

Wenn du es dir einfach machen willst, dann könntest du einfach die JEDI VCL und TJvHtListBox nehmen, da kannst du einfach HTML-Code schreiben. Links, Fettdruck, alles ganz einfach.

Wenn du es selbst machen willst, dann solltest du beim Zeichnen des Links dir das Rechteck speichern, in dem die Schrift steht. Mit DT_CALCRECT als Parameter für DrawText kannst du das Rechteck ja leicht bestimmen.
Bei Mausbewegungen und Klicks müsstest du dann diese Liste durchgehen und ggf. entsprechend reagieren. Dabei hilft PtInRect. Zusätzlich müsstest du den Mauszeiger bei OnMouseLeave zurücksetzen.

[Keldorn]

hat mich jetzt doch mal interessiert, ich würde es so angehen, ähnlich, wie von jaenicke vorgeschlagen:

Delphi-Quellcode:

procedure TForm1.FormCreate(Sender: TObject);
Var i:integer;
begin
  ListBox_luckie.Style := lbOwnerDrawFixed;
  ListBox_luckie.ItemHeight := 3*ListBox_luckie.canvas.TextHeight('Wg')+4;

  //nur paar Testeinträge
  for i := 1 to 10 do
    ListBox_luckie.items.add('');
end;

procedure TForm1.ListBox_luckieDrawItem(Control: TWinControl; Index: Integer;
  ARect: TRect; State: TOwnerDrawState);
Var SName,STel,SMail:string;
    Textrect:Trect;
    Hoehe:integer;
    Maus:Tpoint;
begin
  SName:='Name'+inttostr(index);
  STel:='0351-123456789-'+inttostr(index);
  smail:='Email'+inttostr(index)+'@blub.de';

  with (Control as TListbox) do
  begin
    hoehe:= canvas.TextHeight('Wg');
    if odSelected in State then
      begin
        Canvas.Font.Color := clHighlightText;
        canvas.brush.color:= clHighlight;
      end
     else
      begin
        Canvas.Font.Color := clWindowText;
        //leichtes Zebramuster
        if odd(index) then
          canvas.brush.color:= clWindow
         else
          //uses graphutil
          canvas.brush.color:= ColorAdjustLuma(colortorgb(clwindow),-10,false);
      end;
    Canvas.FillRect(ARect);

    textrect:=rect(arect.left+2,
                   arect.top+1,
                   arect.Right,
                   arect.Bottom);
    //Name
    canvas.font.style := [fsbold];
    DrawText(Canvas.Handle, PChar(SName), length(sName), TextRect, DT_LEFT);

    //Tel
    offsetrect(Textrect,0,hoehe);
    canvas.font.style := [];
    DrawText(Canvas.Handle, PChar(Stel), length(sTel), TextRect, DT_LEFT);

    //mail
    offsetrect(Textrect,0,hoehe);
    Maus := ScreenToClient(Mouse.CursorPos);

    if PtInRect(textrect,Maus) then
      canvas.font.style := [fsUnderline]
     else
      canvas.font.style := [];
    //für selected noch ändern
    canvas.font.color := clblue;
    DrawText(Canvas.Handle, PChar(Smail), length(Smail), TextRect, DT_LEFT);
  end;

end;

procedure TForm1.ListBox_luckieMouseMove(Sender: TObject; Shift: TShiftState; X,  Y: Integer);
Var Mailrect:Trect;
    Index:integer;
    NeuerCursor:Tcursor;
begin
  with sender as TListBox do
    begin
      index:=ItemAtPos(point(x,y),true);
      if index<>-1 then
        begin
          //Rect des Eintrages holen
          mailrect:=ItemRect(index);
          mailrect.Top:=mailrect.top+1+2+2*canvas.TextHeight('Wg');
          //hab ich nicht :-)
          //mailrect.right:=mailrect.right+2+canvas.Textwidth(Mailstring);

          if PtInRect(mailrect,Point(x,y)) then
            NeuerCursor:=crHandPoint
           else
            NeuerCursor:=crDefault;

          if NeuerCursor<>Cursor then
            begin
              //funktioniert leider noch nicht 100%, aber ich wollte nicht immer die LB komplett neuzeichnen
              //manchmal bleibt das fsunderline bestehen, aber ich wollte auch ohne globaleren Veriablen auskommen
              InvalidateRect(handle,@mailrect,true);
              //invalidate;
              cursor:=NeuerCursor;
            end;
        end;
    end;

end;

in deinem ondrawtiem würde ich

Delphi-Quellcode:

Var Contract:Tcontract;
...
  contract:=TContact((AControl as TListbox).Items.Objects[AIndex]); 
  Nachname:=contract.name;

für übersichtlicher halten

[Luckie]

Auf die Idee beim MouseMove das Rechteck der Mailadresse immer neu zu berechnen bin ich nicht gekommen. Man müsste es jetzt nur für zwei Adressen erweitern. Wobei wenn nur eine angegeben ist diese immer links steht, egal ob es die erste oder zweite ist. Aber das werde ich mir heute Abend mal angucken. Gefallen tut mir auch die unterschiedliche Färbung jedes zweiten Eintrages. Das werde ich wohl auch übernehmen. Vielen Dank schon mal für deine Hilfe.