Moving images while drag and drop - delphi

I have an TImage on a TPanel, and an other (empty) TPanels. I want to drag
the image from the first to the second panel using the drag and drop.
I actually want to see the image while it's moving from one panel to the
other (semi-transparent).
I think I should use TDragObject.GetDragImages but I can't figure out how to construct the whole magic.
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Image1.ControlStyle := Image1.ControlStyle + [csDisplayDragImage]; // ???
TImage(Sender).BeginDrag(False);
end;
procedure TForm1.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
// ???
end;
procedure TForm1.Panel1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
if (Source is TImage) then
Accept := TImage(Source).Parent <> Sender;
end;
procedure TForm1.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if (Source is TImage) then
begin
TImage(Source).Parent := TPanel(Sender);
TImage(Source).Align := alClient;
end;
end;
Update - I found a useful article: Implementing Professional Drag & Drop In VCL/CLX Applications

unit Unit3;
interface
// 2012 Thomas Wassermann - demo
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMyDragObject = class(TDragControlObject)
private
FImageList:TImageList;
FDragSource:TControl;
protected
function GetDragImages: TDragImageList; override;
public
Procedure StartDrag(G:TGraphic;p:TPoint;DragSource:TControl);
Constructor Create(AControl: TControl); override;
Destructor Destroy;override;
Property DragSource:TControl read FDragSource;
end;
TForm3 = class(TForm)
Panel1: TPanel;
Panel2: TPanel;
Image1: TImage;
procedure Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure FormCreate(Sender: TObject);
procedure Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure FormDestroy(Sender: TObject);
procedure Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
private
{ Private-Deklarationen }
FDragObject:TMyDragObject;
public
{ Public-Deklarationen }
end;
var
Form3: TForm3;
implementation
constructor TMyDragObject.Create(AControl: TControl);
begin
inherited;
FImageList:=TImageList.Create(nil);
end;
destructor TMyDragObject.Destroy;
begin
FImageList.Free;
inherited;
end;
function TMyDragObject.GetDragImages: TDragImageList;
begin
Result := FImageList;
end;
{$R *.dfm}
procedure TMyDragObject.StartDrag(G: TGraphic;p:TPoint;DragSource:TControl);
var
bmp:TBitMap;
begin
FDragSource := DragSource;
bmp:=TBitMap.Create;
try
FImageList.Width := g.Width;
FImageList.Height := g.Height;
bmp.Width := g.Width;
bmp.Height := g.Height;
bmp.Canvas.Draw(0,0,g);
FImageList.Add(bmp,nil);
finally
bmp.Free;
end;
FImageList.SetDragImage(0,p.x,p.y)
end;
procedure TForm3.FormCreate(Sender: TObject);
var
i:Integer;
begin
ControlStyle := ControlStyle + [csDisplayDragImage];
for I := 0 to ControlCount -1 do
if Controls[i] is TPanel then
TPanel(Controls[i]).ControlStyle := TPanel(Controls[i]).ControlStyle + [csDisplayDragImage];
ReportMemoryLeaksOnShutDown := True;
end;
procedure TForm3.FormDestroy(Sender: TObject);
begin
if Assigned(FDragObject) then FDragObject.Free;
end;
procedure TForm3.Image1StartDrag(Sender: TObject; var DragObject: TDragObject);
var
p:TPoint;
begin
p:=TImage(Sender).ScreenToClient(mouse.cursorpos);
if Assigned(FDragObject) then FDragObject.Free;
FDragObject := TMyDragObject.Create(TImage(Sender));
FDragObject.StartDrag(TImage(Sender).Picture.Graphic,p,TImage(Sender));
DragObject := FDragObject;
end;
procedure TForm3.Panel1DragDrop(Sender, Source: TObject; X, Y: Integer);
begin
if FDragObject.DragSource is TImage then
TImage(FDragObject.DragSource).Parent := TPanel(Sender);
end;
procedure TForm3.Panel1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
begin
Accept := Source is TMyDragObject;
end;
end.

Related

How to download a file with progress with IdHTTP via https

I'm trying to download a file using indy10 http components TIdHttp while getting the progress , I have just setted the libraries in the application folder while using the code for http URL it works and progress but with https it simply does nothing and it doesn't raises any exception :/
with TIdHTTP.Create(nil) do
begin
IOHndl:=TIdSSLIOHandlerSocketOpenSSL.Create(nil);
Request.BasicAuthentication:=True;
HandleRedirects:=True;
IOHandler:=IOHndl;
OnWork:=FOnWork;
OnWorkBegin:=FOnWorkBegin;
OnWorkEnd:=FOnWorkEnd;
Get(FUrl,FStream);
end;
Best Regards
First you have to create a small class to wrap the HTTP component:
unit IdHTTPProgressU;
interface
uses
Classes, IdBaseComponent, IdComponent, IdTCPConnection, IdTCPClient, IdHTTP, IdSSLOpenSSL;
{$M+}
type
TIdHTTPProgress = class(TIdHTTP)
private
FProgress: Integer;
FBytesToTransfer: Int64;
FOnChange: TNotifyEvent;
IOHndl: TIdSSLIOHandlerSocketOpenSSL;
procedure HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
procedure HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
procedure HTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
procedure SetProgress(const Value: Integer);
procedure SetOnChange(const Value: TNotifyEvent);
public
Constructor Create(AOwner: TComponent);
procedure DownloadFile(const aFileUrl: string; const aDestinationFile: String);
published
property Progress: Integer read FProgress write SetProgress;
property BytesToTransfer: Int64 read FBytesToTransfer;
property OnChange: TNotifyEvent read FOnChange write SetOnChange;
end;
implementation
uses
Sysutils;
{ TIdHTTPProgress }
constructor TIdHTTPProgress.Create(AOwner: TComponent);
begin
inherited;
IOHndl := TIdSSLIOHandlerSocketOpenSSL.Create(nil);
Request.BasicAuthentication := True;
HandleRedirects := True;
IOHandler := IOHndl;
ReadTimeout := 30000;
OnWork := HTTPWork;
OnWorkBegin := HTTPWorkBegin;
OnWorkEnd := HTTPWorkEnd;
end;
procedure TIdHTTPProgress.DownloadFile(const aFileUrl: string; const aDestinationFile: String);
var
LDestStream: TFileStream;
aPath: String;
begin
Progress := 0;
FBytesToTransfer := 0;
aPath := ExtractFilePath(aDestinationFile);
if aPath <> '' then
ForceDirectories(aPath);
LDestStream := TFileStream.Create(aDestinationFile, fmCreate);
try
Get(aFileUrl, LDestStream);
finally
FreeAndNil(LDestStream);
end;
end;
procedure TIdHTTPProgress.HTTPWork(ASender: TObject; AWorkMode: TWorkMode; AWorkCount: Int64);
begin
if BytesToTransfer = 0 then // No Update File
Exit;
Progress := Round((AWorkCount / BytesToTransfer) * 100);
end;
procedure TIdHTTPProgress.HTTPWorkBegin(ASender: TObject; AWorkMode: TWorkMode; AWorkCountMax: Int64);
begin
FBytesToTransfer := AWorkCountMax;
end;
procedure TIdHTTPProgress.HTTPWorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
FBytesToTransfer := 0;
Progress := 100;
end;
procedure TIdHTTPProgress.SetOnChance(const Value: TNotifyEvent);
begin
FOnChance := Value;
end;
procedure TIdHTTPProgress.SetProgress(const Value: Integer);
begin
FProgress := Value;
if Assigned(FOnChance) then
FOnChance(Self);
end;
end.
I wont go in to details with the calss: Just say that it bacally wraps a TIdhttp component in and assign the 3 events: OnBegin, onWork and OnEnd
The Method DownloadFile does the actually download,
Then when you have to use it you could do like this:
Place a Button and a PrograssBar on an empty form. Add IdHTTPProgressU to the uses list.
Declare a vaiable of TIdHTTPProgress and a local onChangeEvent
Your form definition should lokke like this:
type
TForm1 = class(TForm)
Button1: TButton;
ProgressBar1: TProgressBar;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
procedure IdHTTPProgressOnChange(Sender : TObject);
public
IdHTTPProgress: TIdHTTPProgress;
end;
Then you just have to implement the methods:
{ TForm1 }
procedure TForm1.Button1Click(Sender: TObject);
begin
IdHTTPProgress.OnChange := IdHTTPProgressOnChance;
IdHTTPProgress.OnChance := IdHTTPProgressOnChance;
IdHTTPProgress.DownloadFile('https://wordpress.org/latest.zip', 'latest.zip');
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
IdHTTPProgress := TIdHTTPProgress.Create(Self);
end;
procedure TForm1.IdHTTPProgressOnChance(Sender: TObject);
begin
ProgressBar1.Position := TIdHTTPProgress(Sender).Progress;
Application.ProcessMessages;
end;
Thats about it. Give it at try.

User moving Shape at run time

I have a unit called MachineShapes, with a type TShape on it. I am trying to get it so when a user clicks on shape they can move it. I think iam close but got a little confused. Thanks for any help
MachineShapes
unit MachineShape;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, extctrls,myDataModule,Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TMachine = class(TShape)
private
{ Private declarations }
FOnMouseDown : TNotifyEvent;
FOnMouseUp: TNotifyEvent;
FonMouseMove: TNotifyEvent;
procedure ControlMouseDown(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
procedure ControlMouseMove(Sender: TObject;
Shift: TShiftState;
X, Y: Integer);
procedure ControlMouseUp(Sender: TObject;
Button: TMouseButton;
Shift: TShiftState;
X, Y: Integer);
private
inReposition : boolean;
oldPos : TPoint;
Protected
procedure DoMouseDown; virtual;
procedure DoMouseUp; Virtual;
procedure DoMouseMove; virtual;
Published
property OnMouseDown: TNotifyEvent Read FOnMouseDown Write fOnMouseDown;
property OnMouseMove: TNotifyEvent Read FOnMouseMove write fOnMouseMove;
Property onMouseUp : TNotifyEvent Read FOnMouseUp write FOnMouseUp;
public
{ Public declarations }
end;
implementation
uses
deptlayout;
procedure TMachine.ControlMouseMove(Sender: TObject; Shift: TShiftState; X: Integer; Y: Integer);
const
minWidth = 20;
minHeight = 20;
var
newPos: TPoint;
frmPoint : TPoint;
begin
if inReposition then
begin
with TWinControl(Sender) do
begin
GetCursorPos(newPos);
Screen.Cursor := crSize;
Left := Left - oldPos.X + newPos.X;
Top := Top - oldPos.Y + newPos.Y;
oldPos := newPos;
end;
end;
end;
procedure TMachine.ControlMouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer);
begin
if inReposition then
begin
Screen.Cursor := crDefault;
ReleaseCapture;
inReposition := False;
end;
end;
procedure TMachine.ControlMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer);
begin
inReposition:=True;
SetCapture(TWinControl(Sender).Handle);
GetCursorPos(oldPos);
end;
procedure tmachine.DoMouseDown;
begin
if assigned(fonmousedown) then
fonmousedown(self);
end;
procedure tmachine.DoMouseUp;
begin
if assigned(fonmouseup) then
fonmouseup(self);
end;
procedure tmachine.domousemove;
begin
if assigned(fonmousemove) then
fonmousemove(self);
end;
end.
How i call it..
procedure TFGetZoneDept.CreateShape(Sender: TObject);
var
machine : TMachine;
begin
//creates the shape
machine := MachineShape.TMachine.Create(fdeptlayout); //form to create shape on
machine.Parent := fdeptlayout; //form to add shape to
machine.OnMouseDown := machinemouseDown;
machine.OnMouseUp := machinemouseUp;
machine.OnMouseMove:= machinemouseMove;
end;
procedure TFGetZoneDept.MachineMouseDown(Sender: TObject);
var
machine: TMachine;
begin
machine := Sender as TMachine;
end;
procedure TFGetZoneDept.MachineMouseUp(Sender: TObject);
var
machine: TMachine;
begin
machine := Sender as TMachine;
end;
procedure TFGetZoneDept.machineMouseMove(Sender: TObject);
var
machine: TMachine;
begin
machine := sender as Tmachine;
end;
A shape is no Wincontrol and has no handle you could do something tike that....
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
type
TMachine=Class(TShape)
private
FX,FY:Integer;
Procedure MyMouseDown(var msg:TWMLButtonDown);message WM_LButtonDown;
Procedure MyMouseMove(var msg:TWMMouseMove);message WM_MouseMove;
End;
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
FX,FY:Integer;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TMachine }
procedure TMachine.MyMouseDown(var msg: TWMLButtonDown);
begin
inherited;
FX := msg.XPos;
FY := msg.YPos;
end;
procedure TMachine.MyMouseMove(var msg: TWMMouseMove);
begin
inherited;
if ssLeft in KeysToShiftState(msg.Keys) then
begin
Left := Left+ msg.XPos -FX;
Top := Top + msg.YPos -FY;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
With TMachine.Create(self) do
begin
Parent := Self;
Width := 200;
Height := 200;
end;
end;
end.

TTreeView selection glitch while dragging a node

I'm implementing drag-and-drop functionality to a TTreeView. On a OnStartDrag Event of it, I'm creating the DragOcject of my derived class:
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
end;
procedure TfrmMain.tvTreeStartDrag(Sender: TObject;
var DragObject: TDragObject);
begin
DragObject := TTreeDragControlObject.Create;
TTreeDragControlObject(DragObject).FText := tvTree.Selected.Text;
end;
And this is my override GetDragImages function of my DragObcject:
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
Everything works fine except it has a painting glitch while dragging over the tree nodes:
How can I avoid this behavior?
Based on #Sean's and #bummi's answers I would post the entire code and conclusions that worked for me in D5.
On WinXP XPManifest is not a must - Hide/ShowDragImage are needed.
On Win7 XPManifest is needed. Hide/ShowDragImage are not a must.
Conclusion - use both XPManifest and HideDragImage and ShowDragImage to ensure TV will work both on XP/Win7.
type
TTreeDragControlObject = class(TDragControlObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
public
destructor Destroy; override;
procedure HideDragImage; override;
procedure ShowDragImage; override;
property DragText: string read FText write FText;
end;
TForm1 = class(TForm)
TreeView1: TTreeView;
procedure TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
procedure TreeView1DragOver(Sender, Source: TObject; X, Y: Integer; State: TDragState; var Accept: Boolean);
procedure TreeView1EndDrag(Sender, Target: TObject; X, Y: Integer);
private
FDragObject: TTreeDragControlObject;
public
end;
...
{ TTreeDragControlObject}
destructor TTreeDragControlObject.Destroy;
begin
FDragImages.Free;
inherited;
end;
procedure TTreeDragControlObject.HideDragImage;
begin
GetDragImages.HideDragImage;
end;
procedure TTreeDragControlObject.ShowDragImage;
begin
GetDragImages.ShowDragImage;
end;
function TTreeDragControlObject.GetDragImages: TDragImageList;
var
Bmp: TBitmap;
begin
if FDragImages = nil then
begin
FDragImages := TDragImageList.Create(nil);
Bmp := TBitmap.Create;
try
Bmp.Width := Bmp.Canvas.TextWidth(FText) + 25;
Bmp.Height := Bmp.Canvas.TextHeight(FText);
Bmp.Canvas.TextOut(25, 0, FText);
FDragImages.Width := Bmp.Width;
FDragImages.Height := Bmp.Height;
FDragImages.SetDragImage(FDragImages.Add(Bmp, nil), 0, 0);
finally
Bmp.Free;
end;
end;
Result := FDragImages;
end;
{ TForm1 }
procedure TForm1.TreeView1StartDrag(Sender: TObject; var DragObject: TDragObject);
begin
FDragObject := TTreeDragControlObject.Create(TTreeView(Sender));
FDragObject.DragText := TTreeView(Sender).Selected.Text;
DragObject := FDragObject;
end;
procedure TForm1.TreeView1DragOver(Sender, Source: TObject; X, Y: Integer;
State: TDragState; var Accept: Boolean);
begin
Accept := Source is TTreeDragControlObject;
end;
procedure TForm1.TreeView1EndDrag(Sender, Target: TObject; X, Y: Integer);
begin
FDragObject.Free;
end;
Note that in your code both FDragImages and var DragObject are leaking memory. I'd suggest using TDragControlObject instead of TDragObject (does your tvTreeEndDrag fire at all now? - it did not fire for me)
Using TXPManifest fixes this bug in D7.
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XPMan, ComCtrls;
additional:
procedure Win7UpdateFix(Form: TForm; CharCode: Word);
var i: Integer;
begin
if Assigned(Form) and (Win32MajorVersion >= 6) and (Win32Platform = VER_PLATFORM_WIN32_NT) then //Vista, Win7
begin
case CharCode of
VK_MENU, VK_TAB: //Alt or Tab
begin
for i := 0 to Form.ComponentCount-1 do
begin
if Form.Components[i] is TWinControl then
begin
//COntrols that disappear - Buttons, Radio buttons, Checkboxes
if (Form.Components[i] is TButton)
or (Form.Components[i] is TRadioButton)
or (Form.Components[i] is TCheckBox) then
TWinControl(Form.Components[i]).Invalidate;
end;
end;
end;
end;
end;
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word;
Shift: TShiftState);
begin
if key=VK_MENU then
begin
Win7UpdateFix(Self,key)
end;
end;
This same behaviour occurs in Delphi 2010 and TXPManifest does not fix it. By co-incidence I recently and independently came across this same problem in a Delphi 2010 application. The solution is to implement the HideDragImage()/ShowDragImage() methods like so ...
TTreeDragControlObject = class(TDragObject)
private
FDragImages: TDragImageList;
FText: String;
protected
function GetDragImages: TDragImageList; override;
public
procedure HideDragImage; override;
procedure ShowDragImage; override;
end;
... and then ...
procedure TTreeDragControlObject.HideDragImage;
begin
FDragImages.HideDragImage
end;
procedure TTreeDragControlObject.ShowDragImage;
begin
FDragImages.ShowDragImage
end;
The conseequence of this is that the windows API function ImageList_DragShowNolock() is called just before and after the drag image is painted ( via windows message TVM_SELECTITEM( TVGN_DROPHILITE)) . Without this function being called, the drag image is not properly painted. The need for ImageList_DragShowNolock(False/True) delimiting TVM_SELECTITEM+TVGN_DROPHILITE is a poorly documented feature, and if other forums are to judge, is a common cause for complaint.

How to add more objects to my form without adding the same amount of code

I have been making a small game for fun. In the game you are a small spaceship(an image) that shoots lazer beams(shape) at an object(panel). At this moment u can only fire one lazer beam at a time because there is only one lazer beam(shape) and there is only one object(panel) to shoot. So with the coding I have I would like to know how I can add more lazer beams and objects but especially lazer beams because I don't want to repeat the procedures for each lazer beam and for each panel.
Here is the code.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, jpeg;
type
TForm1 = class(TForm)
Panel1: TPanel;
Timer1: TTimer;
Timer2: TTimer;
Button1: TButton;
Shape1: TShape;
Timer3: TTimer;
Image1: TImage;
procedure Timer2Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure Timer3Timer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
public
procedure StartPanelAnimation1;
procedure DoPanelAnimationStep1;
function PanelAnimationComplete1: Boolean;
procedure Startlazeranimation1;
procedure DolazeranimationStep1;
{ Public declarations }
end;
var
Form1: TForm1;
implementation
var key : char;
{$R *.dfm}
{ TForm1 }
{ TForm1 }
procedure TForm1.DoPanelAnimationStep1;
begin
Panel1.Top := Panel1.Top+1;
end;
function TForm1.PanelAnimationComplete1: Boolean;
begin
Result := Panel1.Top=512;
end;
procedure TForm1.StartPanelAnimation1;
begin
Panel1.Top := 0;
Timer1.Interval := 1;
Timer1.Enabled := True;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
DoPanelAnimationStep1;
if PanelAnimationComplete1 then
StartPanelAnimation1;
if (shape1.Top < panel1.Top) and (shape1.Left < panel1.Left+104) and (shape1.Left > panel1.Left) then
begin
startpanelanimation1;
sleep(10);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
button1.Hide;
key := 'a';
timer2.Enabled := true;
StartPanelAnimation1;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
shape1.Visible := false;
timer3.Enabled := false;
timer2.Enabled := false;
end;
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
image1.Left := image1.Left-10;
end;
procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
image1.Left := image1.Left+10;
end;
procedure TForm1.DolazeranimationStep1;
begin
shape1.Top := shape1.Top-10;
end;
procedure TForm1.Startlazeranimation1;
begin
shape1.Top := image1.Top;
shape1.Left := image1.Left+55;
shape1.Visible := true;
Timer3.Interval := 1;
Timer3.Enabled := True;
end;
procedure TForm1.Timer3Timer(Sender: TObject);
var k : integer;
begin
DolazeranimationStep1;
if (shape1.Top < panel1.Top) and (shape1.Left < panel1.Left+104) and (shape1.Left > panel1.Left) or (shape1.Top=clientheight) then
begin
timer3.Enabled := false;
shape1.Visible := false;
for k := 1 to 5 do
sleep(1);
begin
application.ProcessMessages;
end;
shape1.Top := 0;
shape1.Left := 0;
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
shape1.Show;
startlazeranimation1;
end;
end.
(The above is the old code)
I have successfully done what Stijn Sanders suggested. But now in this if
if (Shape1.top < panel1.Top) and (shape1.Left < panel1.Left+104) and (shape1.Left > panel1.Left) then
never tests true because shape1 never passes panel1 it, only the shape created on on click passes the panel.
So is there another way to test if the shape is at the pnael.
Not all components need to be created at design time. At run-time, for example using a TTimer and its event, you can call TShape.Create(Self); to have an extra shape. Keep the reference to the resulting value somewhere convenient, for example a (dynamic) array, and remember to set MyShape.Parent:=Self; or MyShape.Parent:=Panel1; so the system knows when and where to display this new control.
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls;
const
MaxRays=100;
RayStep=8;
type
TForm1 = class(TForm)
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Rays:array[0..MaxRays-1] of TShape;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
var
i:integer;
begin
for i:=0 to MaxRays-1 do Rays[i]:=nil;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
var
i:integer;
begin
i:=0;
while (i<MaxRays) and (Rays[i]<>nil) do inc(i);
if i<MaxRays then
begin
Rays[i]:=TShape.Create(Self);
Rays[i].Shape:=stEllipse;
Rays[i].Pen.Color:=clRed;
Rays[i].Pen.Style:=psSolid;
Rays[i].Brush.Color:=clYellow;
Rays[i].Brush.Style:=bsSolid;
Rays[i].SetBounds(X-4,Y-20,9,41);
Rays[i].Parent:=Self;
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
i:integer;
begin
for i:=0 to MaxRays-1 do
if Rays[i]<>nil then
begin
Rays[i].Top:=Rays[i].Top-RayStep;
if Rays[i].Top<0 then FreeAndNil(Rays[i]);
end;
end;
end.
Create your objects dynamically at runtime and keep track of them in a list, then you can loop through the list when needed, eg:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, jpeg;
type
TForm1 = class(TForm)
PanelTimer: TTimer;
Button1: TButton;
LazerTimer: TTimer;
Image1: TImage;
procedure PanelTimerTimer(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormActivate(Sender: TObject);
procedure FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
procedure LazerTimerTimer(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
private
{ Private declarations }
Lazers: TList;
Panels: TList;
procedure StartPanelAnimation;
procedure StartLazerAnimation;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
{ TForm1 }
procedure TForm1.StartPanelAnimation;
var
Panel: TPanel;
begin
Panel := TPanel.Create(Self);
Panel.Parent := Self;
Panel.Top := 0;
// set other Panel properties as needed...
Panel.Visible := True;
Panels.Add(Panel);
if not PanelTimer.Enabled then
begin
PanelTimer.Interval := 1;
PanelTimer.Enabled := True;
end;
end;
procedure TForm1.PanelTimerTimer(Sender: TObject);
var
k: Integer;
Panel: TPanel;
begin
for k := 0 to Panels.Count-1 do
begin
Panel := TPanel(Panels[k]);
Panel.Top := Panel.Top + 1;
if Panel.Top = 512 then
Panel.Top := 0;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StartPanelAnimation1;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Lazers := TList.Create;
Panels := TList.Create;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
Lazers.Free;
Panels.Free;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
PanelTimer.Enabled := False;
LazerTimer.Enabled := False;
end;
procedure TForm1.FormMouseWheelDown(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
Image1.Left := Image1.Left - 10;
end;
procedure TForm1.FormMouseWheelUp(Sender: TObject; Shift: TShiftState;
MousePos: TPoint; var Handled: Boolean);
begin
Image1.Left := Image1.Left + 10;
end;
procedure TForm1.StartLazerAnimation;
var
Lazer: TShape;
begin
Lazer := TShape.Create(Self);
Lazer.Parent := Self;
// set Lazer properties as needed...
Lazer.Top := Image1.Top;
Lazer.Left := Image1.Left + 55;
Lazer.Visible := True;
Lazers.Add(Lazer);
if not Lazer.Enabled then
begin
Lazer.Interval := 1;
Lazer.Enabled := True;
end;
end;
procedure TForm1.LazerTimerTimer(Sender: TObject);
var
k, m : integer;
Lazer: TShape;
Panel: TPanel;
PanelHit: Boolean;
begin
k := 0;
while k < Lazers.Count do
begin
Lazer := TShape(Lazers[k]);
Lazer.Top := Lazer.Top - 10;
for m := 0 to Panels.Count-1 do
begin
Panel := TPanel(Panels[m]);
PanelHit := (Lazer.Top > (Panel.Top+Panel.Height)) and (Lazer.Left > Panel.Left) and (Lazer.Left < (Panel.Left+Panel.Width));
if PanelHit then
begin
Panels.Remove(Panel);
Panel.Free;
if Panels.Count = 0 then
PanelTimer.Enabled := False;
Break;
end;
end;
if PanelHit or (Lazer.Top = 0) then
begin
Lazers.Remove(Lazer);
Lazer.Free;
if Lazers.Count = 0 then
LazerTimer.Enabled := False;
end else
Inc(k);
end;
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
StartLazerAnimation;
end;
end.

What program lock the file

I need a program to overwrite the file, but sometimes some process is lock it. How to check which process locks a file, and how to unlock it? What functions should I use?
I found on the Internet such a code, but it doesn't work me.
unit proc;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, ComCtrls, Grids, ValEdit, MTSUtilsUnit, TLHelp32,
Menus, PsAPI;
type
TApp = class
fPID: Integer;
fPArentPID: Integer;
fPIDName: string;
fThread: Integer;
fDLLName: TStringList;
fDLLPath: TStringList;
fDescription: string;
end;
TForm2 = class(TForm)
StatusBar1: TStatusBar;
Panel1: TPanel;
Panel2: TPanel;
Panel3: TPanel;
Panel4: TPanel;
Splitter2: TSplitter;
Edit1: TEdit;
Button1: TButton;
Label1: TLabel;
RichEdit1: TRichEdit;
PopupMenu1: TPopupMenu;
kill1: TMenuItem;
StringGrid1: TStringGrid;
function GetApps(AppName: string): TStringList;
function GetInfo(PID: Integer): string;
function Kill(PID: Integer): Boolean;
procedure kill1Click(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form2: TForm2;
ApplicationList: TStringList;
row: Integer;
implementation
{$R *.dfm}
function TForm2.Kill(PID: Integer): Boolean;
var fHandle: THandle;
begin
fHandle := OpenProcess(PROCESS_TERMINATE, BOOL(0), PID);
if TerminateProcess(fHandle, 0) then
Result := True
else
Result := False;
CloseHandle(fHandle);
end;
procedure TForm2.kill1Click(Sender: TObject);
var i: Integer;
fApp: TApp;
begin
if Kill(StrToInt(StringGrid1.Cells[1, row])) then
begin
ApplicationList.Delete(row);
StringGrid1.RowCount := ApplicationList.Count;
for i := 1 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
Form2.StringGrid1.Cells[0,i] := fApp.fPIDName;
Form2.StringGrid1.Cells[1,i] := IntToStr(fApp.fPID);
end;
MessageBox(0, 'Terminate successfully', 'Kill', MB_ICONINFORMATION or MB_OK);
end
else
MessageBox(0, 'Could not terminate process', 'Kill', MB_ICONINFORMATION or MB_OK);
end;
procedure TForm2.StringGrid1SelectCell(Sender: TObject; ACol, ARow: Integer;
var CanSelect: Boolean);
var fApp: TApp;
begin
row := ARow;
RichEdit1.Lines.Clear();
if ApplicationList.Count >= row then
begin
fApp := TApp(ApplicationList.Objects[row]);
RichEdit1.Lines.Add(fApp.fDescription);
end;
end;
procedure TForm2.Button1Click(Sender: TObject);
var i: Integer;
fApp: TApp;
sItem: string;
CanSelect: Boolean;
begin
for i := 0 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
FreeAndNil(fApp.fDLLName);
FreeAndNil(fApp.fDLLPath);
FreeAndNil(fApp);
end;
FreeAndNil(ApplicationList);
ApplicationList := GetApps(Edit1.Text);
StringGrid1.RowCount := ApplicationList.Count;
for i := 0 to ApplicationList.Count - 1 do
begin
fApp := TApp(ApplicationList.Objects[i]);
StringGrid1.Cells[0,i] := fApp.fPIDName;
StringGrid1.Cells[1,i] := IntToStr(fApp.fPID);
end;
StringGrid1.OnSelectCell(Self, 0, 1, CanSelect);
end;
procedure TForm2.FormCreate(Sender: TObject);
begin
StringGrid1.Cells[0,0] := 'Name';
StringGrid1.Cells[1,0] := 'PID';
end;
function TForm2.GetInfo(PID: Integer): string;
var fHandle: THandle;
fModule: TModuleEntry32;
sInfo: string;
begin
Result := '';
sInfo := 'DLL Name: %s'#13#10 +
'DLL Path: %s'#13#10 +
'ModuleId: %d'#13#10;
fHandle := CreateToolhelp32Snapshot(TH32CS_SNAPMODULE, PID);
if fHandle <> INVALID_HANDLE_VALUE then
if Module32First(fHandle, fModule) then
repeat
if SameText(ExtractFileExt(fModule.szModule), '.dll') then
begin
sInfo := Format(sInfo, [fModule.szModule, fModule.szExePath, fModule.th32ModuleID]);
Result := Result + sInfo;
end;
until not Module32Next(fHandle, fModule);
end;
function TForm2.GetApps(AppName: string): TStringList;
var fHandle: THandle;
fModHandle: THandle;
fProcess: TProcessEntry32;
fModule: TMODULEENTRY32;
App: TApp;
i: Integer;
IsDLL: Boolean;
IsProcess: Boolean;
fDesc: string;
sPath: string;
begin
IsDLL := False;
IsProcess := False;
Result := TStringList.Create();
Result.Clear();
fDesc := 'DLL Name: %s'#13#10 +
'DLL Path: %s'#13#10 +
'ModuleId: %d'#13#10;
fHandle := CreateToolHelp32SnapShot(TH32CS_SNAPPROCESS, 0);
fProcess.dwSize := SizeOf(fProcess);
IsProcess := Process32First(fHandle, fProcess);
while IsProcess do
begin
App := TApp.Create();
App.fDLLName := TStringList.Create();
App.fDLLPath := TStringList.Create();
fModHandle := CreateToolHelp32SnapShot(TH32CS_SNAPMODULE, fProcess.th32ProcessID);
IsDLL := Module32First(fModHandle, fModule);
while IsDLL do
begin
if Edit1.Text <> '' then
sPath := fModule.szModule
else
sPath := ExtractFileExt(fModule.szModule);
if SameText(sPath, Edit1.Text + '.dll') then
begin
App.fPID := fProcess.th32ProcessID;
App.fPIDName := fProcess.szExeFile;
App.fDLLName.Add(fModule.szModule);
App.fDLLPath.Add(fModule.szExePath);
App.fDescription := App.fDescription +
Format(fDesc, [fModule.szModule, fModule.szExePath, fModule.th32ModuleID]);
end;
IsDLL := Module32Next(fModHandle, fModule)
end;
if App.fDLLName.Count > 0 then
Result.AddObject(IntToStr(App.fPID), App);
IsProcess := Process32Next(fHandle, fProcess);
end;
CloseHandle(fHandle);
Result.Count;
end;
end.
You should not unlock the file yourself this will lead to lost data! Leave it to the user and instead show an error and explaining which process holds open the file.
This solution here will help you to do so:
http://www.remkoweijnen.nl/blog/2011/01/03/cannot-access-files-but-need-the-origin
Check out Process Explorer. It will show you which processes have which files opened, and will allow you to close individual files.

Resources