// Die Wingdings-Zeichen werden auf einem TImage angezeigt
// (ähnlich wie bei CharMap) und beim Anklicken z.B. an ein
// TLabel übertragen.


// Getestet mit RS 10.4 unter Win11
 

const 
  Zeichenbreite = 35; 
  Zeichenhoehe = 28; 
  Spaltenzahl = 20; 
  Zeilenzahl = 12; 
 
var 
  FontName: string; 
  OK: Boolean = False; 
 
procedure AnzeigeWD(Img: TImage); 
var 
  Zeile, Spalte: Integer; 
  A: AnsiChar; 
begin 
  With Img, Picture.Bitmap, Canvas do 
  begin 
    AutoSize := true; 
    Width := Spaltenzahl * Zeichenbreite; 
    Height := Zeilenzahl * Zeichenhoehe; 
    FillRect(ClipRect); 
    Font.Name := FontName; 
    Font.Size := 14; 
    Spalte := 0; 
    Zeile := 0; 
    FillRect(ClipRect); 
    for A := #33 to #255 do 
    begin 
      TextOut(Spalte * Zeichenbreite, Zeile * Zeichenhoehe, String(A)); 
      inc(Spalte); 
      if Spalte = Spaltenzahl then 
      begin 
        Spalte := 0; 
        inc(Zeile); 
      end; 
    end; 
  end; 
  OK := true; 
end; 
 
function Zeichen(X, Y: Integer): AnsiChar; 
var 
  Value: Byte; 
begin 
  X := X div Zeichenbreite; 
  Y := Y div Zeichenhoehe; 
  Value := 33 + X + Y * Spaltenzahl; 
  Result := AnsiChar(Value); 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Label1.caption := ''; 
  FontName := 'Wingdings'; 
  Label1.Font.Name := FontName; 
  AnzeigeWD(Image1); 
end; 
 
// Oder auch 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  Label1.caption := ''; 
  FontName := 'Webdings'; 
  Label1.Font.Name := FontName; 
  AnzeigeWD(Image1); 
end;

// z.B.
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; 
  Shift: TShiftState; X, Y: Integer); 
begin 
  if OK then 
  begin 
    Label1.ShowAccelChar := False; 
    Label1.caption := String(Zeichen(X, Y)); 
  end 
  else 
    ShowMessage('Image ist noch nicht gefüllt'); 
end;

Zugriffe seit 6.9.2001 auf Delphi-Ecke