// Eine Grafik (außer Icon) kann auf verschiedene Art
// in eine Bitmap anderer Größe eingepasst werden.
// Siehe auch
Bilder in Images einpassen

// Getestet mit D4 und D7 unter XP


 

type 
  kind = (center, fit, relative, stretch); 
 
function InsertGraphic(src: TGraphic; dst: TBitmap; 
  wdth, hgth: Integer; ground: TColor; like: kind): byte; 
var 
  rct: TRect; 
begin 
  if (wdth < 3) or (hgth < 3) then begin 
    Result := 1; 
    exit; 
  end; 
  if (src.Width < 3) or (src.Height < 3) then begin 
    Result := 2; 
    exit; 
  end; 
  if src is TIcon then begin 
    Result := 3; 
    exit; 
  end; 
  try 
    dst.Width := wdth; 
    dst.Height := hgth; 
    case like of 
      stretch: rct := rect(0, 0, wdth, hgth); 
      fit: begin 
          if (wdth / src.Width) < (hgth / src.Height) then 
            hgth := round((wdth * src.Height) / src.Width) 
          else wdth := round((src.Width * hgth) / src.Height); 
          rct.Left := ((dst.Width - wdth) div 2); 
          rct.Top := ((dst.Height - hgth) div 2); 
          rct.Right := rct.Left + wdth; 
          rct.Bottom := rct.Top + hgth; 
        end; 
      relative: begin 
          wdth := dst.Width; 
          hgth := round(wdth * (src.Height / src.Width)); 
          if hgth < dst.Height then begin 
            hgth := dst.Height; 
            wdth := round(hgth * (src.Width / src.Height)); 
          end; 
          rct.Left := ((dst.Width - wdth) div 2); 
          rct.Top := ((dst.Height - hgth) div 2); 
          rct.Right := rct.Left + wdth; 
          rct.Bottom := rct.Top + hgth; 
        end; 
    else begin 
        rct.Left := ((dst.Width - src.Width) div 2); 
        rct.Top := ((dst.Height - src.Height) div 2); 
        rct.Right := rct.Left + src.Width; 
        rct.Bottom := rct.Top + src.Height; 
      end; 
    end; 
    dst.Canvas.Brush.Color := ground; 
    dst.Canvas.FillRect(dst.Canvas.ClipRect); 
    SetStretchBltMode(dst.Canvas.handle, STRETCH_HALFTONE); 
    dst.Canvas.StretchDraw(rct, src); 
    Result := 0; 
  except 
    Result := 4; 
  end; 
end; 
 
// Beispielaufruf 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  bm: TBitmap; 
begin 
  bm := TBitmap.create; 
  case InsertGraphic(Image1.picture.graphic, bm, 200, 100, clred, fit) of 
    0: canvas.draw(10, 10, bm); 
    1: showmessage('Abmaße des Zielbildes zu gering'); 
    2: showmessage('Abmaße des Quellbildes zu gering'); 
    3: showmessage('Icons werden nicht unterstützt'); 
  else showmessage('Unerwarteter Fehler'); 
  end; 
  bm.free; 
end;
 



 

Zugriffe seit 6.9.2001 auf Delphi-Ecke