DBCtrlGrid Drag and Drop - delphi

Tried with no success to drag and drop a row to switch positions (using a ClientDataSet in memory)
The specific case is: a ClientDataSet with image file names who will result in an ordered list that will be used to create export to a PDF document where each image is a page (this is why the order is important).
The DbCtrlGrid is used to visualize a thumbnail of the image, and I was trying to use drag-and-drop to exchange their positions, but I couldn't get information about the row where I dropped in the end.
It would help a method to get info about the row where the mouse is over when the OnDragDrop event triggers or any other idea
please

I imagine your q is prompted by the fact that although the TDBCtrlGrid has a
PanelIndex property which tells you which one of the grid's virtual panels
is active (i.e. is the one for the current row in the dataset), this doesn't
change while you've moving the mouse around e.g. during a drag operation. However,
it is not difficult to calculate this yourself, as follows.
The Height and Width of a TDBCtrlGrid are exact multiples of its RowCount and
ColCount. In the simple case of ColCount =1, it is trivially simple
to calculate which Row contains a given Y coordinate within the grid:
function TForm1.PanelIndexFromYPos(Y : Integer) : Integer;
var
PanelHeight : Integer;
begin
PanelHeight := DBCtrlGrid1.ClientHeight div DBCtrlGrid1.RowCount;
Result := Y div PanelHeight;
end;
(obviously this is for the simple case of a single column goVertical orientated grid but would be easy to generalise)
Now, the TBDCtrlGrid's EndDrag (and MouseOver) tells you the Y coordinate of the TPoint where the
drag operation ends, so you can use this PanelIndexFromYPos function to tell you
which row index the user has dropped the dragged row onto. As #KenWhite explained,
you then need to re-order your CDS to reflect the new position the dragged row should be in.
This is easy to do if your CDS has a DisplayIndex field representing what row position
a given record in the CDS and the CDS has an active index on this field. Re-ordering
the CDS's records is a bit of a rigmarole, as will be apparent from the following sample project.
TForm1 = class(TForm)
CDS1: TClientDataSet;
DataSource1: TDataSource;
DBGrid1: TDBGrid;
DBCtrlGrid1: TDBCtrlGrid; // Note: DragMode set to dmManual;
DBText1: TDBText; // In the DBCtrlGrid
DBText2: TDBText;
DBText3: TDBText;
edSourceIndex: TEdit;
edDestIndex: TEdit;
btnTest: TButton;
Memo1: TMemo;
Label1: TLabel;
procedure FormCreate(Sender: TObject);
procedure DBCtrlGrid1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure DBCtrlGrid1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure DBCtrlGrid1DragDrop(Sender, Source: TObject; X, Y: Integer);
procedure btnTestClick(Sender: TObject);
private
procedure MoveRow(SourceIndex, DestIndex : Integer);
procedure LogMove(OldValue, NewValue: Integer);
procedure ShowPanelInfo(Y: Integer);
protected
function PanelIndexFromYPos(Y : Integer) : Integer;
public
SourceIndex : Integer; // the DbCtrlGrid PanelIndex of the row being dragged
DestIndex : Integer; // the PanelIndex where the row is dropped
end;
[...]
function TForm1.PanelIndexFromYPos(Y : Integer) : Integer;
var
PanelHeight : Integer;
begin
PanelHeight := DBCtrlGrid1.ClientHeight div DBCtrlGrid1.RowCount;
Result := Y div PanelHeight;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
AField : TField;
begin
// Create the fields for the CDS
AField := TIntegerField.Create(Self);
AField.FieldName := 'ID';
AField.DataSet := CDS1;
// This DisplayIndex field will be used to determine which row number in
// the DBCtrlGrid will occupy, by indexing the CDS on this field
AField := TIntegerField.Create(Self);
AField.FieldName := 'DisplayIndex';
AField.DataSet := CDS1;
AField := TStringField.Create(Self);
AField.FieldName := 'Name';
AField.Size := 20;
AField.DataSet := CDS1;
CDS1.CreateDataSet;
// Add some data which will appear in the grid in reverse-alphabetical order
CDS1.InsertRecord([1, 3, 'A']);
CDS1.InsertRecord([2, 2, 'B']);
CDS1.InsertRecord([3, 1, 'C']);
CDS1.InsertRecord([4, 0, 'D']);
CDS1.IndexFieldNames := 'DisplayIndex';
end;
procedure TForm1.DBCtrlGrid1MouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
SourceIndex := PanelIndexFromYPos(Y);
DBCtrlGrid1.BeginDrag(False);
end;
end;
procedure TForm1.DBCtrlGrid1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := True;
end;
procedure TForm1.DBCtrlGrid1DragDrop(Sender, Source: TObject; X,
Y: Integer);
begin
ShowPanelInfo(Y);
DestIndex := PanelIndexFromYPos(Y);
MoveRow(SourceIndex, DestIndex);
end;
procedure TForm1.MoveRow(SourceIndex, DestIndex : Integer);
var
BM : TBookMark;
Index : Integer;
procedure SetCDSIndex(Value : Integer);
var
OldValue : Integer;
begin
OldValue := CDS1.FieldByName('DisplayIndex').AsInteger;
CDS1.Edit;
CDS1.FieldByName('DisplayIndex').AsInteger := Value;
CDS1.Post;
LogMove(OldValue, Value);
end;
begin
if SourceIndex = DestIndex then exit;
CDS1.DisableControls;
try
if CDS1.FindKey([SourceIndex]) then begin
BM := CDS1.GetBookmark; // This is to keep track of the dragged row without needing to
// keep track of its (changing) DisplayIndex
if SourceIndex > DestIndex then begin
// i.e. we're moving the dragged row up in the grid
// so starting with the row above it we move the rows upwards
// eventually leaving a gap to drop the dragged row into
Index := SourceIndex - 1;
while Index >= DestIndex do begin
if CDS1.FindKey([Index]) then begin
SetCDSIndex(Index + 1);
end;
Dec(Index);
end;
end
else begin
// i.e. we're moving the dragged row down in the grid
// so starting with the row below it we move the rows upwards
// eventually leaving a gap to drop the dragged row into
Index := SourceIndex + 1;
while Index <= DestIndex do begin
if CDS1.FindKey([Index]) then begin
SetCDSIndex(Index - 1);
end;
Inc(Index);
end;
end;
end;
CDS1.GotoBookMark(BM);
if CDS1.FieldByName('DisplayIndex').AsInteger = SourceIndex then begin
SetCDSIndex(DestIndex);
end;
CDS1.FreeBookmark(BM); // should really have it's own try...finally but hey!
finally
CDS1.EnableControls;
end;
end;
procedure TForm1.LogMove(OldValue, NewValue : Integer);
begin
Memo1.Lines.Add(Format('Name: %s Old: %d New: %d ', [CDS1.FieldByName('Name').AsString, OldValue, NewValue]));
end;
procedure TForm1.ShowPanelInfo(Y : Integer);
begin
Label1.Caption := Format('y: %d panelindex: %d', [Y, PanelIndexFromYPos(Y)]);
end;
procedure TForm1.btnTestClick(Sender: TObject);
begin
// For debugging, to test mving rows without needing to drag/drop
MoveRow(StrToInt(edSourceIndex.Text), StrToInt(edDestIndex.Text));
end;
end.

Related

Delphi + TeeChart : how can I get checkbox in legend for pie serie values?

I want to allow the user to choose what values are shown in a chart with a pie serie values by displaying a check box in front of each serie's value.
There is an option to display a checkbox near each legend item but it's only working for series, not values in a serie ; and you can only have one serie of values in a single pie.
Does anyone have any idea on how to achieve this?
You could draw your custom legend manually. However, you should do some tricks:
use a dummy series to store the original values and show these values in the legend.
remove the values from the main series that have been clicked in the legend taking care with the indexes and the colors.
Here an example, even with mouse Hover:
uses Series, TeCanvas, Math;
var pieSeries: TPieSeries;
dummySeries: TPieSeries;
itemRect: array of TRect;
itemIndex: Integer;
procedure TForm1.Chart1AfterDraw(Sender: TObject);
var i, tmpH, tmpW: Integer;
tmpR, tmpS: TRect;
begin
with Chart1.Canvas do
begin
AssignFont(Chart1.Legend.Font);
AssignBrush(Chart1.Legend.Brush);
tmpW:=0;
tmpH:=0;
for i:=0 to dummySeries.Count-1 do
begin
tmpW:=Max(TextWidth(dummySeries.LegendString(i, Chart1.Legend.TextStyle)), tmpW);
tmpH:=Max(TextHeight(dummySeries.LegendString(i, Chart1.Legend.TextStyle)), tmpH);
end;
Inc(tmpW, Chart1.Legend.Symbol.Width + TeeCheckBoxSize + 8);
tmpR.Left:=Chart1.Width-tmpW-10;
tmpR.Top:=50;
tmpR.Right:=tmpR.Left+tmpW;
tmpR.Bottom:=tmpR.Top + ((tmpH+4) * dummySeries.Count) + 4;
Rectangle(tmpR);
Inc(tmpR.Left, 4);
tmpS.Left:=tmpR.Left+TeeCheckBoxSize+4;
tmpS.Right:=tmpS.Left+TeeCheckBoxSize;
for i:=0 to dummySeries.Count-1 do
begin
Brush.Color:=OperaPalette[i];
Inc(tmpR.Top, 4);
DrawCheckBox(tmpR.Left, tmpR.Top, not dummySeries.IsNull(i), clNone);
if i=itemIndex then
begin
Pen.Color:=clRed;
Font.Color:=clRed;
end
else
begin
Pen.Color:=Chart1.Legend.Symbol.Pen.Color;
Font.Color:=Chart1.Legend.Font.Color;
end;
tmpS.Top:=tmpR.Top+1;
tmpS.Bottom:=tmpS.Top+TeeCheckBoxSize;
Rectangle(tmpS);
TextOut(tmpS.Right + 2, tmpR.Top, StringReplace(dummySeries.LegendString(i, Chart1.Legend.TextStyle), TeeColumnSeparator, ' ', [rfReplaceAll, rfIgnoreCase]));
itemRect[i]:=Rect(tmpR.Left, tmpS.Top, tmpR.Right, tmpS.Bottom);
Inc(tmpR.Top, tmpH);
end;
end;
end;
procedure TForm1.Chart1Click(Sender: TObject);
var i, j: Integer;
begin
if itemIndex>-1 then
begin
dummySeries.SetNull(itemIndex, not dummySeries.IsNull(itemIndex));
pieSeries.CheckDataSource;
for i:=pieSeries.Count-1 downto 0 do
if pieSeries.IsNull(i) then
pieSeries.Delete(i);
//Fix colors
j:=0;
for i:=0 to dummySeries.Count-1 do
if not dummySeries.IsNull(i) then
begin
pieSeries.ValueColor[j]:=OperaPalette[i];
Inc(j);
end;
end;
end;
procedure TForm1.Chart1MouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
var i, j: Integer;
begin
itemIndex:=-1;
for i:=0 to length(itemRect)-1 do
if PointInRect(itemRect[i], X, Y) then
begin
itemIndex:=i;
break;
end;
if itemIndex>-1 then
begin
if dummySeries.IsNull(itemIndex) then
pieSeries.Selected.HoverIndex:=-1
else
begin
j:=0;
for i:=0 to itemIndex-1 do
if not dummySeries.IsNull(i) then
Inc(j);
pieSeries.Selected.HoverIndex:=j;
end;
end;
Chart1.CancelMouse:=True;
Chart1.Repaint;
end;
procedure TForm1.FormCreate(Sender: TObject);
var i: Integer;
begin
pieSeries:=Chart1.AddSeries(TPieSeries) as TPieSeries;
pieSeries.FillSampleValues;
for i:=0 to pieSeries.Count-1 do
pieSeries.ValueColor[i]:=OperaPalette[i];
dummySeries:=CloneChartSeries(pieSeries) as TPieSeries;
dummySeries.ParentChart:=nil;
pieSeries.DataSource:=dummySeries;
Chart1.Legend.Visible:=False;
Chart1.MarginRight:=20;
SetLength(itemRect, dummySeries.Count);
itemIndex:=-1;
end;

Ownerdraw TListBox child controls are not moved by scrolling

procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
begin
inherited;
TListBox(Control).Canvas.FillRect(Rect);
TListBox(Control).Canvas.TextOut(Rect.Left+5, Rect.Top+8, TListBox(Control).Items[Index]);
if odSelected in State then
begin
Button.Left:=Rect.Right-80;
Button.Top:=Rect.Top+4;
Button.Visible:=true;
Button.Invalidate;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
ListBox1.DoubleBuffered:=true;
ListBox1.ItemHeight:=30;
ListBox1.Style:=lbOwnerDrawFixed;
Button:=TButton.Create(ListBox1);
Button.Parent:=ListBox1;
Button.DoubleBuffered:=true;
Button.Visible:=false;
Button.Width:=50;
Button.Height:=20;
Button.Caption:='BTN';
end;
The repaint problem only exists when using ScrollBar or sending WM_VSCROLL message to my ListBox. All normally drawn when I change selection by using keyboard arrows or mouse clicks. Problem also not exists when selected item are visible by scrolling and not leave visible area.
I think that Button.Top property still have an old value before DrawItem calls, and change (to -30px for example) later.
The problem is that you are using the OnDrawItem event to make changes to the UI (in this case, positioning the button). Do not do that, the event is for DRAWING ONLY.
I would suggest that you either:
subclass the ListBox to handle the WM_VSCROLL message and have your message handler reposition the button as needed.
var
PrevListBoxWndProc: TWndMethod;
procedure TForm1.FormCreate(Sender: TObject);
begin
PrevListBoxWndProc := ListBox1.WindowProc;
ListBox1.WindowProc := ListBoxWndProc;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
ListBox1.WindowProc := PrevListBoxWndProc;
end;
procedure TForm1.PositionButton(Index: Integer);
var
R: TRect;
begin
if Index <= -1 then
Button.Visible := False
else
begin
R := ListBox1.ItemRect(Index);
Button.Left := R.Right - 80;
Button.Top := R.Top + 4;
Button.Visible := True;
end;
end;
var
LastIndex: Integer = -1;
procedure TForm1.ListBox1Click(Sender: TObject);
var
Index: Integer;
begin
Index := ListBox1.ItemIndex;
if Index <> LastIndex then
begin
LastIndex := Index;
PositionButton(Index);
end;
end;
procedure TForm1.ListBoxWndProc(var Message: TMessage);
begin
PrevListBoxWndProc(Message);
if Message.Msg = WM_VSCROLL then
PositionButton(ListBox1.ItemIndex);
end;
get rid of the TButton altogether. Use OnDrawItem to draw an image of a button (you can use DrawFrameControl() or DrawThemeBackground() for that) directly onto the ListBox, and then use the OnMouseDown/Up or OnClick event to check if the mouse is over the "button" and if so act accordingly as needed.
var
MouseX: Integer = -1;
MouseY: Integer = -1;
procedure TForm1.ListBox1DrawItem(Control: TWinControl; Index: Integer;
Rect: TRect; State: TOwnerDrawState);
var
R: TRect;
P: TPoint;
BtnState: UINT;
begin
TListBox(Control).Canvas.FillRect(Rect);
TListBox(Control).Canvas.TextOut(Rect.Left+5, Rect.Top+8, TListBox(Control).Items[Index]);
if not (odSelected in State) then Exit;
R := Rect(Rect.Right-80, Rect.Top+4, Rect.Right-30, Rect.Top+24);
P := Point(MouseX, MouseY);
BtnState := DFCS_BUTTONPUSH;
if PtInRect(R, P) then BtnState := BtnState or DFCS_PUSHED;
DrawFrameControl(TListBox(Control).Canvas.Handle, R, DFC_BUTTON, BtnState);
InflateRect(R, -4, -4);
DrawText(TListBox(Control).Canvas.Handle, 'BTN', 3, R, DT_CENTER or DT_VCENTER or DT_SINGLELINE);
end;
procedure TForm1.ListBox1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then Exit;
MouseX := X;
MouseY := Y;
ListBox1.Invalidate;
end;
procedure TForm1.ListBox1MouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button <> mbLeft then Exit;
MouseX := -1;
MouseY := -1;
ListBox1.Invalidate;
end;
procedure TForm1.ListBox1Click(Sender: TObject);
var
P: TPoint;
R: TRect;
Index: Integer;
begin
P := Point(MouseX, MouseY);
Index := ListBox1.ItemAtPos(P, True);
if (Index = -1) or (Index <> ListBox1.ItemIndex) then Exit;
R := ListBox1.ItemRect(Index);
R := Rect(R.Right-80, R.Top+4, R.Right-30, R.Top+24);
if not PtInRect(R, P) then Exit;
// click is on selected item's "button", do something...
end;

Delphi Graphics32 relative mouse position (to the layer)

I have a ImgView32, that is anchored to all form margins. The form is maximized.
The bitmap of ImgView is not fixed (it can be of different sizes)
I am trying to draw a line on a transparent layer using ther code from this question:Drawing lines on layer
Now the problem is that, using that exact code, I can only draw in the top-left corner, like in this image:
As you can observe, the lines can be drawn only in the left top corner.
If I try to add some value to the Start and End Points, the whole thing goes crazy. So I must find a way to translate the points in such a fashion that, the user will be able to draw only inside of the center rect (visible in the image)
I am out of ideas.
Please help
Here is the whole unit:
unit MainU;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,GR32, GR32_Image, GR32_Layers, GR32_Backends, GR32_PNG, StdCtrls,
ExtCtrls;
type
TForm5 = class(TForm)
ImgView: TImgView32;
Button1: TButton;
Memo: TMemo;
Edit3: TEdit;
Button2: TButton;
RadioGroup1: TRadioGroup;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
procedure ImgViewResize(Sender: TObject);
private
{ Private declarations }
FStartPoint, FEndPoint: TPoint;
FDrawingLine: boolean;
bm32: TBitmap32;
BL : TBitmapLayer;
FSelection: TPositionedLayer;
public
{ Public declarations }
procedure AddLineToLayer;
procedure AddCircleToLayer;
procedure SwapBuffers32;
procedure LayerMouseDown(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseUp(Sender: TObject; Buttons: TMouseButton;Shift: TShiftState; X, Y: Integer);
procedure LayerMouseMove(Sender: TObject; Shift: TShiftState;X, Y: Integer);
procedure LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
procedure SetSelection(Value: TPositionedLayer);
property Selection: TPositionedLayer read FSelection write SetSelection;
Procedure SelectGraficLayer(idu:string);
procedure AddTransparentPNGlayer;
end;
var
Form5: TForm5;
implementation
{$R *.dfm}
var
imwidth: integer;
imheight: integer;
OffsX, OffsY: Integer;
const
penwidth = 3;
pencolor = clBlue; // Needs to be a VCL color!
procedure TForm5.AddLineToLayer;
begin
bm32.Canvas.Pen.Color := pencolor;
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
procedure TForm5.FormCreate(Sender: TObject);
var
P: TPoint;
W, H: Single;
begin
imwidth := Form5.ImgView.Width;
imheight := Form5.ImgView.Height;
with ImgView.PaintStages[0]^ do
begin
if Stage = PST_CLEAR_BACKGND then Stage := PST_CUSTOM;
end;
bm32 := TBitmap32.Create;
bm32.DrawMode := dmTransparent;
bm32.SetSize(imwidth,imheight);
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.Pen.Color := pencolor;
with ImgView do
begin
Selection := nil;
Layers.Clear;
Scale := 1;
Scaled := True;
Bitmap.DrawMode := dmTransparent;
Bitmap.SetSize(imwidth, imheight);
Bitmap.Canvas.Pen.Width := 4;//penwidth;
Bitmap.Canvas.Pen.Color := clBlue;
Bitmap.Canvas.FrameRect(Rect(20, 20, imwidth-20, imheight-20));
Bitmap.Canvas.TextOut(15, 32, 'ImgView');
end;
AddTransparentPNGLayer;
BL := TBitmapLayer.Create(ImgView.Layers);
try
BL.Bitmap.DrawMode := dmTransparent;
BL.Bitmap.SetSize(imwidth,imheight);
BL.Bitmap.Canvas.Pen.Width := penwidth;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Location := GR32.FloatRect(0, 0, imwidth, imheight);
BL.Scaled := False;
BL.OnMouseDown := LayerMouseDown;
BL.OnMouseUp := LayerMouseUp;
BL.OnMouseMove := LayerMouseMove;
BL.OnPaint := LayerOnPaint;
except
Edit3.Text:=IntToStr(BL.Index);
BL.Free;
raise;
end;
FDrawingLine := false;
SwapBuffers32;
end;
procedure TForm5.FormDestroy(Sender: TObject);
begin
bm32.Free;
BL.Free;
end;
procedure TForm5.ImgViewPaintStage(Sender: TObject; Buffer: TBitmap32;
StageNum: Cardinal);
const //0..1
Colors: array [Boolean] of TColor32 = ($FFFFFFFF, $FFB0B0B0);
var
R: TRect;
I, J: Integer;
OddY: Integer;
TilesHorz, TilesVert: Integer;
TileX, TileY: Integer;
TileHeight, TileWidth: Integer;
begin
TileHeight := 13;
TileWidth := 13;
TilesHorz := Buffer.Width div TileWidth;
TilesVert := Buffer.Height div TileHeight;
TileY := 0;
for J := 0 to TilesVert do
begin
TileX := 0;
OddY := J and $1;
for I := 0 to TilesHorz do
begin
R.Left := TileX;
R.Top := TileY;
R.Right := TileX + TileWidth;
R.Bottom := TileY + TileHeight;
Buffer.FillRectS(R, Colors[I and $1 = OddY]);
Inc(TileX, TileWidth);
end;
Inc(TileY, TileHeight);
end;
end;
procedure TForm5.ImgViewResize(Sender: TObject);
begin
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X-OffsX, Y-OffsY);
FDrawingLine := true;
end;
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm5.SetSelection(Value: TPositionedLayer);
begin
if Value <> FSelection then
begin
FSelection := Value;
end;
end;
procedure TForm5.SwapBuffers32;
begin
TransparentBlt(
BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;
procedure TForm5.AddTransparentPNGlayer;
var
mypng:TPortableNetworkGraphic32;
B : TBitmapLayer;
P: TPoint;
W, H: Single;
begin
try
mypng := TPortableNetworkGraphic32.Create;
mypng.LoadFromFile('C:\Location\Of\ATransparentPNGFile.png');
B := TBitmapLayer.Create(ImgView.Layers);
with B do
try
mypng.AssignTo(B.Bitmap);
Bitmap.DrawMode := dmBlend;
with ImgView.GetViewportRect do
P := ImgView.ControlToBitmap(GR32.Point((Right + Left) div 2, (Top + Bottom) div 2));
W := Bitmap.Width * 0.5;
H := Bitmap.Height * 0.5;
Location := GR32.FloatRect(P.X - W, P.Y - H, P.X + W, P.Y + H);
Scaled := True;
OnMouseDown := LayerMouseDown;
except
Free;
raise;
end;
Selection := B;
Edit3.Text:=IntToStr(B.Index);
finally
mypng.Free;
end;
end;
end.
What am I doing wrong? Please test the unit above to see what I mean. Remember to add a ImgView and anchor it to all margins, then at runtime, maximize the form and try to draw the lines...
EDIT
In the green image above, there is a rect, more like a square in the middle of it (not very visible) but you can see it if you look closely.
Since my problem might be misunderstood, please take a look at the following image
I need to be able to draw ONLY in the white rectangle (Bitmap) in the middle of the ImgView. I do not know how to explain better.
It is not a solution for me to make the rectangle/Bitmap fit exactly the ImgView, because that is not the point of my project.
Take a look at Paint.net and imagine that my project kind of does the same (except it's not that complex). But the principle is the same: you decide the size of your document/image when you start a new project, then you add different images as layers, you scale and rotate them, and now I want to allow the users to draw lines inside of a special layer (the drawing layer)
But everything happens inside the boundaries of that document size. Like for example in the above image, the size of the document there is A5 (100dpi) scaled at 83%.
So my problem is that I cannot allow the users to draw the lines outside the white rectangle (middle of the screen). So their lines can start in those boundaries and end there.
I know my test unit is not perfectly clean. I pasted some functions used in the main project and quickly removed some parts from them that are not relevant to this example. The AddTransparentPng procedure is there only to allow the testing of adding a transparent image to the ImgView so I can test if the drawing layer is not covering another possible latyer.
(The Scaled property belongs to the layer (B) it's under the 'with B' statement. I removed the With 'ImgView.Bitmap... Location' statement so it would not bother you anymore :) )
Anyway, please do not pay attention to the code that does not affect the drawing of lines. That code is what needs attention.
EDIT
If I set the layer's scaled to true (Scaled:=true) then it messes everything up, like in the image bellow:
I still have to use offsets but a little differently
Thank you
Error one
In LayerMouseMove() you subtract OffsX and OffsY from FStartPoint in BL.Bitmap.Canvas.MoveTo(). FStartPoint was already adjusted in LayerMouseDown(). I told you to "In the three Mouse procs adjust the X and Y arguments only to become X-OffsX and Y-OffsY." Note arguments only Here's LayerMouseMove() corrected:
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
// BL.Bitmap.Canvas.MoveTo(FStartPoint.X-OffsX, FStartPoint.Y-OffsY);
BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
Error two
I also told you to add if FDrawingLine then ... condition to LayerMouseUp() to avoid spurious line when the mouse down happens outside of the layer, but mouse up occurs inside. The corrected LayerMouseUp():
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
end;
Error three
The posted code does not perform as your first image shows. The image looks like you would have outcommented the line BL.Location := ... in ImgViewResize(). Possibly you did this because of Error one. Anyway, with ImgViewResize as follows and the other corrections above I get the result as shown in the picture that follows.
procedure TForm5.ImgViewResize(Sender: TObject);
begin
// centering the drawing area
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
Variables imwidth and imheight defines the size of the drawing area. If you change these you need to recalculate OffsX and OffsY and you need to resize the backbuffer bm32 as well.
The lines in the corners indicate the extent of the drawing area (defined by imwidth and imheight) in the middle of the window. It stays the same also when the window is maximized.
Ok, I solved it. Here is the final (relevant) code:
procedure TForm5.ImgViewResize(Sender: TObject);
begin
OffsX := (ImgView.ClientWidth - imwidth) div 2;
OffsY := (ImgView.ClientHeight - imheight) div 2;
BL.Location := GR32.FloatRect(OffsX, OffsY, imwidth+OffsX, imheight+OffsY);
end;
procedure TForm5.SwapBuffers32;
begin
TransparentBlt(
BL.Bitmap.Canvas.Handle, 0, 0, BL.Bitmap.Width, BL.Bitmap.Height,
bm32.Canvas.Handle, 0, 0, bm32.Width, bm32.Height, clWhite);
end;
procedure TForm5.LayerMouseDown(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FStartPoint := Point(X-OffsX, Y-OffsY);
FDrawingLine := true;
end;
procedure TForm5.LayerMouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
begin
if FDrawingLine then
begin
SwapBuffers32;
BL.Bitmap.Canvas.Pen.Color := pencolor;
BL.Bitmap.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
BL.Bitmap.Canvas.LineTo(X-OffsX, Y-OffsY);
end;
end;
procedure TForm5.LayerMouseUp(Sender: TObject; Buttons: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
FDrawingLine := false;
FEndPoint := Point(X-OffsX, Y-OffsY);
AddLineToLayer;
SwapBuffers32;
end;
procedure TForm5.LayerOnPaint(Sender: TObject; Buffer: TBitmap32);
begin
SwapBuffers32;
end;
procedure TForm5.AddLineToLayer;
begin
bm32.Canvas.Pen.Color := pencolor;
bm32.Canvas.Pen.Width := penwidth;
bm32.Canvas.MoveTo(FStartPoint.X, FStartPoint.Y);
bm32.Canvas.LineTo(FEndPoint.X, FEndPoint.Y);
end;
With this code, everything works as expected. The drawing of lines can only happen within the boundaries
Thank you

How to drag report in ppviewer?

Anyone know how to drag the report in TppViewer? (Delphi 7) i try to use the dagdrop event and dragover event of ppviewer but failed, anyone can help?
procedure Tfrm1.ppviewer1DragOver(Sender, Source: TObject; X,
Y: Integer; State: TDragState; var Accept: Boolean);
begin
inherited;
Accept := Source IS TppViewer;
end;
procedure Tfrm1.ppviewer1DragDrop(Sender, Source: TObject; X,
Y: Integer);
begin
inherited;
if Source is TppViewer then begin
TppViewer(Source).Left := X;
TppViewer(Source).Top := Y;
end;
end;
This answer assumes that you are trying to scroll in the report, by dragging.
TReportPreviewer is the Form
ReportViewer is the ppViewer
Dragging is a Boolean
SaveX, SaveY are Integer
procedure TReportPreviewer.ReportViewerMouseDown(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Dragging := true;
SaveX := X;
SaveY := Y;
end;
procedure TReportPreviewer.ReportViewerMouseMove(Sender: TObject;
Shift: TShiftState; X, Y: Integer);
begin
if Dragging then
begin
if ReportViewer.ScrollBox.Visible then
ReportViewer.ScrollBox.HorzScrollBar.Position := ReportViewer.ScrollBox.HorzScrollBar.Position - (X - SaveX);
if ReportViewer.ScrollBox.Visible then
ReportViewer.ScrollBox.VertScrollBar.Position := ReportViewer.ScrollBox.VertScrollBar.Position - (Y - SaveY);
SaveX := X;
SaveY := Y;
end;
end;
procedure TReportPreviewer.ReportViewerMouseUp(Sender: TObject;
Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Dragging := false;
end;
I tried using ScrollBy instead of moving the scrollbar position, but it seemed to reset for some reason.
Are you trying to drag a report file into the Viewer? if so biased on the following advice:
How to Drop Images from Windows Explorer to a TImage control
Delphi - Drag & Drop with ListView
WM_DROPFILES Message
You can achieve this by using the following code:
procedure TMainForm.FormCreate(Sender: TObject);
begin
//Tell Windows that the Report Viewer accepts files
ShellAPI.DragAcceptFiles(ppViewer1.Handle,True);
Application.OnMessage := ApplicationMessage;
end;
procedure TMainForm.ApplicationMessage(var Msg: TMsg; var Handled: Boolean);
begin
if (Msg.hwnd = ppViewer1.Handle) and (Msg.message = WM_DROPFILES) then
begin
Handled := ReportFileDrop(Msg);
end;
end;
function TMainForm.ReportFileDrop(var Msg: TMsg):Boolean ;
var
numFiles : longInt;
buffer : array[0..MAX_PATH] of char;
l_file:String;
l_filemsg:TWMDROPFILES;
begin
Result := False;
//Convert the TMsg into a TWMDROPFILES record
l_filemsg.Msg := Msg.message;
l_filemsg.Drop := Msg.wParam;
l_filemsg.Unused := Msg.lParam;
l_filemsg.Result := 0;
numFiles := DragQueryFile(l_filemsg.Drop, $FFFFFFFF, nil, 0) ;
if numFiles > 1 then
begin
ShowMessage('You can drop only one file at a time!') ;
end
else
begin
try
DragQueryFile(l_filemsg.Drop, 0, #buffer, sizeof(buffer)) ;
l_file := buffer;
//Only try and load the report if the file has the correct extension
if (Length(l_file) > 0) and (ExtractFileExt(LowerCase(l_file)) = '.rtm') then
begin
//Load the Report
Result := True;
end;
except
//Handle errors
end;
end;
end;

Scroll TTreeView while dragging over/near the edges

I have a TTreeView that can have lots of nodes, when a lot of nodes are expanded the tree uses a lot of screen space.
Now suppose I want to drag a node that is near the bottom of the TreeView to the top, I can't physically see the top part of the TreeView because the node I am selecting is at the bottom. When dragging the node to the top of the TreeView I would like the TreeView to automatically scroll with me when dragging, by default this does not seem to happen.
A perfect example of this behaviour is seen in Windows Explorer. If you try to drag a file or folder, when you hover the dragged item (node) it automatically scrolls up or down depending on cursor position.
Hope that makes sense.
PS, I already know how to drag nodes, I want the TreeView to scroll with me when dragging if hovering near the top or bottom of the TreeView.
Thanks.
This is the code I use. It will work for any TWinControl descendent: list box, tree view, list view etc.
type
TAutoScrollTimer = class(TTimer)
private
FControl: TWinControl;
FScrollCount: Integer;
procedure InitialiseTimer;
procedure Timer(Sender: TObject);
public
constructor Create(Control: TWinControl);
end;
{ TAutoScrollTimer }
constructor TAutoScrollTimer.Create(Control: TWinControl);
begin
inherited Create(Control);
FControl := Control;
InitialiseTimer;
end;
procedure TAutoScrollTimer.InitialiseTimer;
begin
FScrollCount := 0;
Interval := 250;
Enabled := True;
OnTimer := Timer;
end;
procedure TAutoScrollTimer.Timer(Sender: TObject);
procedure DoScroll;
var
WindowEdgeTolerance: Integer;
Pos: TPoint;
begin
WindowEdgeTolerance := Min(25, FControl.Height div 4);
GetCursorPos(Pos);
Pos := FControl.ScreenToClient(Pos);
if not InRange(Pos.X, 0, FControl.Width) then begin
exit;
end;
if Pos.Y<WindowEdgeTolerance then begin
SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEUP, 0);
end else if Pos.Y>FControl.Height-WindowEdgeTolerance then begin
SendMessage(FControl.Handle, WM_VSCROLL, SB_LINEDOWN, 0);
end else begin
InitialiseTimer;
exit;
end;
if FScrollCount<50 then begin
inc(FScrollCount);
if FScrollCount mod 5=0 then begin
//speed up the scrolling by reducing the timer interval
Interval := MulDiv(Interval, 3, 4);
end;
end;
if Win32MajorVersion<6 then begin
//in XP we need to clear up transient "fluff"; results in flickering so only do it in XP where it is needed
FControl.Invalidate;
end;
end;
begin
if Mouse.IsDragging then begin
DoScroll;
end else begin
Free;
end;
end;
Then to use it you add an OnStartDrag event handler for the control and implement it like this:
procedure TMyForm.SomeControlStartDrag(Sender: TObject; var DragObject: TDragObject);
begin
TAutoScrollTimer.Create(Sender as TWinControl);
end;
Here's an alternative based on the fact that the selected node always automatically scrolls in view.
type
TForm1 = class(TForm)
TreeView1: TTreeView;
TreeView2: TTreeView;
procedure TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
procedure TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
procedure TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
FDragNode: TTreeNode;
FNodeHeight: Integer;
end;
...
procedure TForm1.TreeViewMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
with TTreeView(Sender) do
begin
FDragNode := GetNodeAt(X, Y);
if FDragNode <> nil then
begin
Selected := FDragNode;
with FDragNode.DisplayRect(False) do
FNodeHeight := Bottom - Top;
BeginDrag(False, Mouse.DragThreshold);
end;
end;
end;
procedure TForm1.TreeViewDragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
var
Pt: TPoint;
DropNode: TTreeNode;
begin
Accept := Source is TTreeView;
if Accept then
with TTreeView(Source) do
begin
if Sender <> Source then
Pt := ScreenToClient(Mouse.CursorPos)
else
Pt := Point(X, Y);
if Pt.Y < FNodeHeight then
DropNode := Selected.GetPrevVisible
else if Pt.Y > (ClientHeight - FNodeHeight) then
DropNode := Selected.GetNextVisible
else
DropNode := GetNodeAt(Pt.X, Pt.Y);
if DropNode <> nil then
Selected := DropNode;
end;
end;
procedure TForm1.TreeViewEndDrag(Sender, Target: TObject; X, Y: Integer);
var
DropNode: TTreeNode;
begin
with TTreeView(Sender) do
if Target <> nil then
begin
DropNode := Selected;
DropNode := Items.Insert(DropNode, '');
DropNode.Assign(FDragNode);
Selected := DropNode;
Items.Delete(FDragNode);
end
else
Selected := FDragNode;
end;
You may want to link the OnDragOver event handler to the parent of the TreeView too, which results in scrolling ánd dropping when the mouse is outside the TreeView. If you dó want the scrolling, but not the dropping when the mouse is outside the TreeView, then check if Target = Sender in the OnEndDrag event handler.
Just to be complete, workarounds like in the other answers are not required anymore. Later versions have an option for this:
TreeOptions.AutoOptions.toAutoScroll := True

Resources