procedure semitransparent(bas, balk: TBitmap; x, y: integer; faktor: byte); 
var 
  p1, p2: pbytearray; 
  i, j, k, m, n, q, w, z: integer; 
begin 
  w := x * 3; 
  z := 256 - faktor; 
  n := balk.width * 3; 
  q := bas.width * 3; 
  for j := 0 to balk.height - 1 do begin 
    k := j + y; 
    if k > bas.height - 1 then exit; 
    if k >= 0 then begin 
      p1 := balk.scanline[j]; 
      p2 := bas.scanline[k]; 
      i := 0; 
      while i < n do begin 
        m := i + w; 
        if (m >= q) then break; 
        if (m >= 0) then begin 
          p1[i] := 
            (p1[i] * faktor + p2[m] * z) shr 8; 
          p1[i + 1] := 
            (p1[i + 1] * faktor + p2[1 + m] * z) shr 8; 
          p1[i + 2] := 
            (p1[i + 2] * faktor + p2[2 + m] * z) shr 8; 
        end; 
        inc(i, 3); 
      end; 
    end; 
  end; 
end; 
 
procedure makebalken(balk, bas, merk: TBitmap; x, y, wdth, hgth: integer; 
  Papier, Stift: TColor; txt: string; faktor: byte); 
var 
  r: TRect; 
begin 
  balk.pixelformat := pf24bit; 
  bas.pixelformat := pf24bit; 
  balk.height := hgth; 
  balk.width := wdth; 
  if merk <> nil then begin 
    merk.height := hgth; 
    merk.width := wdth; 
    merk.canvas.copyrect(rect(0, 0, merk.width, merk.height), 
      bas.canvas, rect(x, y, x + merk.width, y + merk.height)); 
  end; 
  with balk.canvas do begin 
    r := cliprect; 
    brush.color := Papier; 
    fillrect(r); 
    Font.color := stift; 
    drawtext(handle, pchar(txt), -1, r, 
      DT_SINGLELINE or DT_CENTER or DT_VCENTER); 
  end; 
  semitransparent(bas, balk, x, y, faktor); 
  bas.canvas.draw(x, y, balk); 
end; 
 
 
 
 
// Beispiel 1: Vier verschiedene Balken 
 
procedure TForm1.Button1Click(Sender: TObject); 
var 
  balken: TBitmap; 
  w: integer; 
  s: string; 
begin 
  Image1.autosize := true; 
  Image1.picture.loadfromfile('C:\lm.jpg'); 
  balken := TBitmap.Create; 
//--- sicherstellen, dass ein Bitmap im Image ist 
  balken.assign(Image1.picture.Graphic); 
  Image1.Picture.Bitmap.assign(balken); 
//----------------------------------------------- 
  balken.canvas.Font.style := [fsBold]; 
  makebalken(balken, Image1.Picture.Bitmap, nil, 10, 10, 60, 25, 
    clRed, clYellow, 'UNTEN', 135); 
  makebalken(balken, Image1.Picture.Bitmap, nil, 15, 23, 50, 25, 
    clBlue, clWhite, 'OBEN', 105); 
  makebalken(balken, Image1.Picture.Bitmap, nil, 50, 90, 100, 25, 
    clAqua, clGray, 'undurchsichtig', 255); 
  s := 'nur schwach zu sehen'; 
  w := balken.canvas.Textwidth(s) + 10; 
  makebalken(balken, Image1.Picture.Bitmap, nil, 0, 125, w, 25, 
    clPurple, clYellow, s, 55); 
  balken.free; 
end; 
 
 
// ------------------------------------------------------------

// Beispiel2: Einen Balken ein- und ausblenden 
 
var 
  hlp, blkn: TBitmap; 
  da: boolean = false; 
  links, oben: integer; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  hlp := TBitmap.Create; 
  hlp.pixelformat := pf24bit; 
  blkn := TBitmap.Create; 
  links := 15; 
  oben := 100; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  hlp.free; 
  blkn.free; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  if da then begin 
    Image1.canvas.draw(links, oben, hlp); 
    da := false; 
  end else begin 
    makebalken(blkn, Image1.Picture.Bitmap, hlp, links, oben, 160, 25, 
      clLime, clRed, 'Das ist ein Test', 100); 
    da := true; 
  end; 
end;

// ------------------------------------------------------------ 
 
// Beispiel 3: Ein durchsichtiger Werbebalken wandert von 
//             links oben nach rechts unten durch das Bild 
 
var 
  balken, hlp: TBitmap; 
  links, oben, breit, hoch: integer; 
  txt: string; 
 
procedure TForm1.FormCreate(Sender: TObject); 
begin 
  Timer1.interval := 0; 
  balken := TBitmap.create; 
  hlp := TBitmap.create; 
  Image1.autosize := true; 
  Image1.picture.loadfromfile('C:\lm.jpg'); 
//--- sicherstellen, dass ein Bitmap im Image ist 
  hlp.assign(Image1.picture.Graphic); 
  Image1.Picture.Bitmap.assign(hlp); 
//----------------------------------------------- 
  hlp.pixelformat := pf24bit; 
  balken.canvas.font.name := 'Arial'; 
  balken.canvas.font.size := 11; 
  balken.canvas.font.style := [fsBold]; 
  txt := 'DBR.Software';
  breit := balken.canvas.Textwidth(txt) + 6; 
  hoch := balken.canvas.Textheight(txt) + 4; 
  hlp.width := breit; 
  hlp.height := hoch; 
end; 
 
procedure TForm1.FormDestroy(Sender: TObject); 
begin 
  hlp.free; 
  balken.free; 
end; 
 
procedure TForm1.Timer1Timer(Sender: TObject); 
begin 
  Image1.canvas.draw(links, oben, hlp); 
  inc(links, 2); 
  inc(oben); 
  if (oben < Image1.height) and (links < Image1.width) then begin 
    makebalken(balken, Image1.Picture.Bitmap, hlp, links, oben, 
      breit, hoch, clPurple, clYellow, txt, 90); 
  end else begin 
    Timer1.interval := 0; 
    Button1.enabled := true; 
  end; 
end; 
 
// Start 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Button1.enabled := false; 
  links := -breit; 
  oben := -hoch div 2; 
  Timer1.interval := 35; 
end;