Zusatztext an Cursor zu durchscheinend, GetDragImages

[norwegen60]

Hallo,

ich füge einem Cursor in bestimmten Situationen zusätzlichen Info-Text hinzu

Delphi-Quellcode:

function TFcDragControlObject.GetDragImages: TDragImageList;
const
  lMargin = 20;
var
  lBmp: TBitmap;
  lWidth: integer;
  lString: string;
begin
  if FDragImages = nil then
  begin
    FDragImages := TDragImageList.create(nil);
    lBmp := TBitmap.create;
    try
      lBmp.Canvas.Font.Assign(TControlAccess(Control).Font);
      lWidth := 0;
      for lString in FMessageList do
        if lBmp.Canvas.TextWidth(lString) > lWidth then
          lWidth := lBmp.Canvas.TextWidth(lString);
      lBmp.Width := lWidth + lMargin;
      lBmp.Height := lBmp.Canvas.TextHeight(FMessageList.First);

      FDragImages.Width := lBmp.Width;
      FDragImages.Height := lBmp.Height;

      lBmp.Canvas.Brush.Color := clLime;

      for lString in FMessageList do
      begin
        lBmp.Canvas.FillRect(Rect(0, 0, lBmp.Width, lBmp.Height));
        lBmp.Canvas.TextOut(lMargin, 0, lString);
        FDragImages.Add(lBmp, nil);
      end;

      FDragImages.SetDragImage(0, 0, 0);
    finally
      lBmp.Free;
    end;
  end;
  Result := FDragImages;
end;

Mein Problem ist nun, dass der Text durchscheinend angezeigt wird und somit auf Strukturen kaum lesbar ist.
(s. angehängte Grafik, der Cursor ist durch PrintScreen ausgeblendet. Einmal mit Hintergrund clLime)

Weiß jemand, wie ich die Transparenz des Text-Bereichs ändern kann.

Vielen Dank
Gerd

[Sailor]

Vielleicht mit SetBkMode(lBmp.Canvas.Handle,Windows.Opaque)?

[norwegen60]

Hallo,

ich habe es mit       SetBkMode(lBmp.Canvas.Handle, OPAQUE); und       lBmp.Canvas.Brush.Style := bsSolid; versucht. Beides brachte keine Änderung.
Hat sonst noch jemand eine Idee?

Grüße
Gerd

[norwegen60]

Hallo,

hat niemand einen Tip? Ich bin leider nicht weiter gekommen.

Danke
Gerd

[Uwe Raabe]

Sieht aus, als könntest du hier fündig werden: Making a custom drag image opaque in Delphi

[norwegen60]

Hallo,

Zitat von Uwe Raabe:

Sieht aus, als könntest du hier fündig werden: Making a custom drag image opaque in Delphi

Delphi-Quellcode:

unit Unit1;

interface

uses
  Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
  System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
  Vcl.StdCtrls;

type
  TForm1 = class(TForm)
    Button1: TButton;
    Button2: TButton;
    procedure Button2MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure Button2StartDrag(Sender: TObject; var DragObject: TDragObject);
    procedure Button2EndDrag(Sender, Target: TObject; X, Y: Integer);
  private
    FDragObject: TDragObject;
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

uses
  commctrl;

{$R *.dfm}

type
  TMyDragObject = class(TDragObjectEx)
  private
    FDragImages: TDragImageList;
    FImageControl: TWinControl;
  protected
    function GetDragImages: TDragImageList; override;
  public
    constructor Create(ImageControl: TWinControl);
    destructor Destroy; override;
  end;

constructor TMyDragObject.Create(ImageControl: TWinControl);
begin
  inherited Create;
  FImageControl := ImageControl;
end;

destructor TMyDragObject.Destroy;
begin
  FDragImages.Free;
  inherited;
end;

function TMyDragObject.GetDragImages: TDragImageList;
var
  Bmp: TBitmap;
  Pt: TPoint;
begin
  if not Assigned(FDragImages) then begin
    Bmp := TBitmap.Create;
    try
      Bmp.PixelFormat := pf32bit;
      Bmp.Canvas.Brush.Color := clFuchsia;

      // 2px margin at each side just to show image can have transparency.
      Bmp.Width := FImageControl.Width + 4;
      Bmp.Height := FImageControl.Height + 4;
      Bmp.Canvas.Lock;
      FImageControl.PaintTo(Bmp.Canvas.Handle, 2, 2);
      Bmp.Canvas.Unlock;

      FDragImages := TDragImageList.Create(nil);
      FDragImages.Width := Bmp.Width;
      FDragImages.Height := Bmp.Height;
      Pt := Mouse.CursorPos;
      MapWindowPoints(HWND_DESKTOP, FImageControl.Handle, Pt, 1);
      FDragImages.DragHotspot := Pt;
      FDragImages.Masked := True;
      FDragImages.AddMasked(Bmp, clFuchsia);
    finally
      Bmp.Free;
    end;
  end;
  Result := FDragImages;
end;

//--

procedure TForm1.Button2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  (Sender as TWinControl).BeginDrag(False);

  // OnStartDrag is called during the above call so FDragImages is
  // assigned now.
  // The below is the only difference with a normal drag image implementation.
  ImageList_SetDragCursorImage(
      (FDragObject as TMyDragObject).GetDragImages.Handle, 0, 0, 0);
end;

procedure TForm1.Button2StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
  DragObject := TMyDragObject.Create(Sender as TWinControl);
  DragObject.AlwaysShowDragImages := True;
  FDragObject := DragObject;
end;

end.

Grundsätzlich könnte es so funktionieren. Sobald ich den Code aus MouseDown in MouseMove verlege ist der Button Opaque
Wenn ich bei Button2 DragMode := dmAutomatic setze, wird OnMouseDown gar nicht aufgerufen
Wenn ich DragMode := dManual setze und dann

Delphi-Quellcode:

procedure TForm2.Button2MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  Button2.DragMode:=dmAutomatic;
  ImageList_SetDragCursorImage((FDragObject as TMyDragObject).GetDragImages.Handle, 0, 0, 0);
end;

Warum ghet bei mir MouseDown nicht?
bekomme ich eine Zugriffsverletzung, weil FDragObject noch gar nicht existiert

[Uwe Raabe]

Hier (Berlin Update 2) funktioniert es auch im MouseDown mit dem Code aus dem ersten Abschnitt.