DBR Delphi-Ecke

// Mit dem folgenden Code kann man zur Laufzeit mittels "Alpha Blending"
// einen semitransparenten (halbdurchsichtigen) Mauspfeil aus einer
// quadratischen Bitmap-Vorlage erstellen. Dabei wird eine Farbe als völlig
// durchsichtig (z.B. Fläche um den Pfeil herum) und eine Farbe als
// undurchsichtig (z.B. schwarzer Rand) angegeben. Der Rest wird
// halbdurchsichtig, wobei die Variable "Transparenz" die Stufe der
// Durchsichtigkeit angibt (0 = völlig durchsichtig,
// 255 = nicht mehr durchsichtig). "Hotx" und "Hoty" beschreiben den Punkt
// an der Spitze des Mauspfeiles, den sogenannten "Hotspot".


Vorlage	Ergebnis

// Variante 1
// Getestet mit D4 unter XP (Hinweis: Alpha-Blending gibt es erst ab W2000)

function AlphaCursor 
  (Bild: TBitmap; vollTransparent, nichtTransparent: TColor; 
  Transparenz: Byte; Hotx, Hoty: Word): HCURSOR; 
var 
  dc: HDC; 
  T: DWORD; 
  z: integer; 
  i, j: Word; 
  pdw: PDWord; 
  bm: TBitmap; 
  ii: TIconInfo; 
  pBits: Pointer; 
  pbi: PBitmapinfo; 
  bi: BITMAPV5HEADER; 
begin 
  result := 0; 
  if (Bild.Width <> Bild.Height) or (Bild.Width < 1) then exit; 
  bm := TBitmap.create; 
  try 
    pbi := @bi; 
    T := Transparenz shl 24; 
    bi.bV5Size := sizeof(bi); 
    bi.bV5Compression := BI_BITFIELDS; 
    bi.bV5Height := Bild.Height; 
    bi.bV5Width := Bild.Width; 
    bi.bV5Planes := 1; 
    bi.bV5BitCount := 32; 
    bi.bV5BlueMask := $FF; 
    bi.bV5GreenMask := $FF00; 
    bi.bV5RedMask := $FF0000; 
    bi.bV5AlphaMask := $FF000000; 
    dc := GetDC(0); 
    bm.handle := CreateDIBSection(dc, pbi^, DIB_RGB_COLORS, pBits, 0, 0); 
    ReleaseDC(0, dc); 
    bm.Canvas.draw(0, 0, Bild); 
    pdw := pBits; 
    for i := 0 to Bild.Width - 1 do 
      for j := 0 to Bild.Height - 1 do 
      begin 
        z := Bild.Width - i - 1; 
        pdw^ := pdw^ and $FFFFFF; 
        if bm.canvas.pixels[j, z] = nichtTransparent then 
          pdw^ := pdw^ or bi.bV5AlphaMask else 
          if bm.canvas.pixels[j, z] <> vollTransparent then 
            pdw^ := pdw^ or T; 
        inc(pdw); 
      end; 
    ii.fIcon := false; 
    ii.xHotspot := Hotx; 
    ii.yHotspot := Hoty; 
    ii.hbmColor := bm.handle; 
    ii.hbmMask := bm.maskhandle; 
    result := CreateIconIndirect(ii); 
  finally 
    bm.free; 
  end; 
end; 
 
procedure TForm1.Button2Click(Sender: TObject); 
begin 
  screen.cursors[99] := 
    AlphaCursor(Image1.Picture.Bitmap, clred, clblack, 100, 10, 1); 
  if screen.cursors[99] < 1 then 
    showmessage('Fehler') else 
    screen.cursor := 99; 
end;

//-------------------------------------------------------------------------

// Variante 2
// Getestet mit D2010 unter W7
// Das Bild muss nicht quadratisch sein.

const 
  crAlpha = TCursor(99); 
 
procedure Acursor(Bild: string; VollTransparent, NichtTransparent: TColor; 
  Transparenz: Byte; Hotx, Hoty: Word); 
var 
  Bmp: TBitmap; 
  Px: PRGBQuad; 
  X, Y: Integer; 
  BmpMask: TBitmap; 
  II: TIconInfo; 
  AlphaCursor: HCURSOR; 
  r, g, b, rh, gh, bh: Byte; 
begin 
  r := GetRValue(VollTransparent); 
  g := GetGValue(VollTransparent); 
  b := GetBValue(VollTransparent); 
  rh := GetRValue(NichtTransparent); 
  gh := GetGValue(NichtTransparent); 
  bh := GetBValue(NichtTransparent); 
  Bmp := TBitmap.Create; 
  Bmp.LoadFromFile(Bild); 
  Bmp.PixelFormat := pf32bit; 
  for Y := 0 to (Bmp.Height - 1) do 
  begin 
    Px := Bmp.ScanLine[Y]; 
    for X := 0 to (Bmp.Width - 1) do 
    begin 
      if (Px.rgbBlue = b) and (Px.rgbGreen = g) and (Px.rgbRed = r) then 
        Px.rgbReserved := 0 
      else if (Px.rgbBlue = bh) and (Px.rgbGreen = gh) and (Px.rgbRed = rh) then 
        Px.rgbReserved := $FF 
      else 
        Px.rgbReserved := Transparenz; 
      Inc(Px); 
    end; 
  end; 
  Bmp.AlphaFormat := afDefined; 
  BmpMask := TBitmap.Create; 
  BmpMask.SetSize(Bmp.Width, Bmp.Height); 
  II.fIcon := False; 
  II.xHotspot := Hotx; 
  II.yHotspot := Hoty; 
  II.hbmMask := BmpMask.Handle; 
  II.hbmColor := Bmp.Handle; 
  AlphaCursor := CreateIconIndirect(II); 
  BmpMask.Free; 
  Bmp.Free; 
  Win32Check(Bool(AlphaCursor)); 
  Screen.Cursors[crAlpha] := AlphaCursor; 
end; 
 
procedure TForm1.Button1Click(Sender: TObject); 
begin 
  Acursor('D:\Bilder\ac1.bmp', clRed, clBlack, 180, 10, 1); 
  Screen.cursor := crAlpha; 
end;