You must interface with the Windows Shell API module to let
Windows know that your application accepts dropped files (this
can be done in your main form's create event), and then you must
respond to the drag events as they happen by creating an event
handler.
The following is an example of a Delphi form that accepts dropped
files and adds the names of the files to a memo component:
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
Memo1: TMemo;
procedure FormCreate(Sender: TObject);
private
procedure WMDROPFILES(var Message: TWMDROPFILES);
message WM_DROPFILES;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
uses ShellApi;
procedure TForm1.FormCreate(Sender: TObject);
begin
{Let Windows know we accept dropped files}
DragAcceptFiles(Form1.Handle, True);
end;
procedure TForm1.WMDROPFILES(var Message: TWMDROPFILES);
var
NumFiles : longint;
i : longint;
buffer : array[0..255] of char;
begin
{How many files are being dropped}
NumFiles := DragQueryFile(Message.Drop,
-1,
nil,
0);
{Accept the dropped files}
for i := 0 to (NumFiles - 1) do begin
DragQueryFile(Message.Drop,
i,
@buffer,
sizeof(buffer));
Form1.Memo1.Lines.Add(buffer);
end;
end;
end.
This code demonstrates use of windows registery and function overloading to read from registery:
if key doesnt exist it's created and Default passed to key value ReadReg(KeyToRead,DefaultValue)
to write to registery:
writereg(KeyToWrite,ValueToKey)
Supports integer,string and boolean types, other type can be similary added.}
unit module1;
interface
uses Windows, registry;
function WriteReg(Key:string;value:integer) :boolean; overload;
function WriteReg(Key:string;value:boolean) :boolean; overload;
function WriteReg(Key:string;value:String) :boolean; overload;
function ReadReg(Key:string;default:String='') :string; overload;
function ReadReg(Key:string;default:integer=0) :integer; overload;
function ReadReg(Key:string;default:boolean=false):boolean;overload;
const
ApplicationName:string ='MyProgram'; //Your Programname
implementation
function ReadReg(Key:string;default:integer=0):integer;
var
Registry: TRegistry;
begin
Registry :=TRegistry.Create;
Registry.RootKey :=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ ApplicationName,True);
if registry.ValueExists(key) =true then
result:=Registry.readinteger(key)
else
begin
Registry.Writeinteger(key,default);
result:=Registry.readinteger(key);
end;
Registry.Free;
end;
function ReadReg(Key:string;default:string=''):string;
var
Registry : TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey :=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
if registry.ValueExists(key) then
readreg := Registry.readstring(key)
else
begin
Registry.Writestring(key,default);
Readreg := Registry.readstring(key);
end;
Registry.Free;
end;
function ReadReg(Key:string;default:boolean=false):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
if registry.ValueExists(key) then
readreg:=Registry.readbool(key)
else
begin
Registry.Writebool(key,default);
readreg:=Registry.readbool(key);
end;
Registry.Free;
end;
function WriteReg(Key:string;value:boolean):boolean;
var Registry: TRegistry;
begin
Registry:=TRegistry.Create;
Registry.RootKey:=HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.WriteBool(key,value);
result:= registry.KeyExists(key);
Registry.Free;
end;
function WriteReg(Key:string;value:string):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.Writestring(key,value);
result:= registry.KeyExists(key);
Registry.Free;
end;
function WriteReg(Key:string;value:integer):boolean;
var
Registry: TRegistry;
begin
Registry := TRegistry.Create;
Registry.RootKey := HKEY_CURRENT_USER;
Registry.OpenKey('\software\'+ApplicationName,True);
registry.Writeinteger(key,value);
writereg:= registry.KeyExists(key);
Registry.Free;
end;
Compare dates
Uses SysUtils;
...
if(Date < EncodeDate( 2000, 1, 1 )) then
Showmessage(' The date is ' + DateToStr(Date));
…
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls;
type
TForm1 = class(TForm)
ListBox1: TListBox;
procedure FormCreate(Sender: TObject); protected
procedure WMDROPFILES (var Msg: TMessage); message WM_DROPFILES;
private
{ Private-Deklarationen }
public
{ Public-Deklarationen }
end;
var
Form1: TForm1;
implementation
uses shellapi;
{$R *.DFM}
procedure TForm1.WMDROPFILES (var Msg: TMessage);
var i,anzahl, size : integer;
Dateiname : PChar;
begin
inherited;
anzahl := DragQueryFile(Msg.WParam, $FFFFFFFF,Dateiname,255);
for i := 0 to (anzahl - 1) do
begin
size := DragQueryFile(Msg.WParam, i , nil, 0) + 1;
Dateiname:= StrAlloc(size);
DragQueryFile(Msg.WParam,i , Dateiname, size);
listbox1.items.add(StrPas(Dateiname)); StrDispose(Dateiname);
end;
DragFinish(Msg.WParam);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
DragAcceptFiles(Form1.Handle, true);
end;
end.
You may have noticed that using SystemParametersInfo to change the wallpaper when ActiveDesktop is turned on doesn't work. The reason is because you need to use the IActiveDesktop COM interface. Using SystemParametersInfo still works, but it doesn't update the wallpaper.
Note that the IActiveDesktop interface requires a Shell32.dll version >= 4.71. The document titled "Get a File Version" demonstrates how to check the file version and uses the shell32.dll as an example.
Here is an example of using IActiveDesktop to work with
the wallpaper. It assumes that you have 3 labels on a form
and two buttons with the default names.
uses
ComObj, // For CreateComObject and Initialization/Finalization of COM
ShlObj; // For IActiveDesktop
{ The CLASS ID for ActiveDesktop is not defined in ShlObj, while the IID is so we define it here. }
const
CLSID_ActiveDesktop : TGUID = '{75048700-EF1F11D0-9888-06097DEACF9}';
{ Demonstrate getting the Wallpaper }
procedure TForm1.Button1Click(Sender: TObject);
var
ActiveDesktop : IActiveDesktop;
CurrentWallpaper : string;
CurrentPattern : string;
WallpaperOptions : TWallpaperOpt;
TmpBuffer : PWideChar;
begin
// Create the ActiveDesktop COM Object
ActiveDesktop:=CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
// We now need to allocate some memory to get the current Wallpaper.
// However, tmpBuffer is a PWideChar which means 2 bytes make
// up one Char. In order to compenstate for the WideChar, we
// allocate enough memory for MAX_PATH*2
tmpBuffer := AllocMem(MAX_PATH*2);
try
ActiveDesktop.GetWallpaper(tmpBuffer, MAX_PATH*2, 0);
CurrentWallpaper := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentWallpaper <> '' then
Label1.Caption := 'Current Wallpaper: ' + CurrentWallpaper
else
Label1.Caption := 'No Wallpaper set';
// Now get the current Wallpaper options.
// The second parameter is reserved and must be 0.
WallpaperOptions.dwSize := SizeOf(WallpaperOptions);
ActiveDesktop.GetWallpaperOptions(WallpaperOptions, 0);
case WallpaperOptions.dwStyle of
WPSTYLE_CENTER : Label2.Caption := 'Centered';
WPSTYLE_TILE : Label2.Caption := 'Tiled';
WPSTYLE_STRETCH : Label2.Caption := 'Stretched';
WPSTYLE_MAX : Label2.Caption := 'Maxed';
end;
{Now get the desktop pattern. The pattern is a string of decimals whose bit pattern represents a picture. Each decimal represents the on/off state of the 8 pixels in that row. }
tmpBuffer := AllocMem(256);
try
ActiveDesktop.GetPattern(tmpBuffer, 256, 0);
CurrentPattern := tmpBuffer;
finally
FreeMem(tmpBuffer);
end;
if CurrentPattern <> '' then
Label3.Caption := CurrentPattern
else
Label3.Caption := 'No Pattern set';
end;
{ Demonstrate setting the wallpaper }
procedure TForm1.Button2Click(Sender: TObject);
var
ActiveDesktop: IActiveDesktop;
begin
ActiveDesktop := CreateComObject(CLSID_ActiveDesktop) as IActiveDesktop;
ActiveDesktop.SetWallpaper('c:\downloads\images\test.bmp', 0);
ActiveDesktop.ApplyChanges(AD_APPLY_ALL or AD_APPLY_FORCE);
end;
Responds:
Good programming. But I just calling
SystemParametersInfo( SPI_SETDESKWALLPAPER, 0, @WallpaperBMPFileAndPath[1], 3);
uses jpeg;
procedure TForm1.Button1Click(Sender: TObject);
var
bmp : TImage;
jpg : TJpegImage;
begin
bmp := TImage.Create(nil);
jpg := TJpegImage.Create;
bmp.picture.bitmap.LoadFromFile('c:\picture.bmp');
jpg.Assign( bmp.picture.bitmap );
//Here you can set the jpg object's
//properties as compression, size and more
jpg.SaveToFile('c:\picture.jpg');
jpg.Free;
bmp.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
var devmode : TDEVMODE;
d : INTEGER;
litem : TListItem;
p : ^TDevmode;
begin
devmode.dmSize := SizeOf(TDEVMODE);
devmode.dmDriverExtra := 0; d := 0;
listview1.Columns[0].Width := 400;
While EnumDisplaySettings(nil, d, devmode) do
with devmode do
begin
Inc(d);
litem := listview1.Items.Add;
litem.Caption:=Format('Modus %3d : %dx%d, %d Farben(%d Hz)', [d,dmPelsWidth,dmPelsHeight,1 shl(dmBitsPerPel),dmDisplayFrequency]);
new(p);
p^ := Devmode;
litem.Data := p;
end;
end;
procedure TForm1.BitBtn1Click(Sender: TObject);
begin
ChangeDisplaySettings(TDevmode(listview1.Selected.data^),0);
end;
DiskFree(n) //where n = number.
0 = the current drive you are working in. 1 = A, 2 = B, 3 = C, 4 = D etc.
DiskFree(3);// C drive.
DiskFree returns the number of free bytes on the specified drive number.
Procedure Opendoor;
Begin
mciSendString('Set cdaudio door open', nil, 0, 0);
End;
Procedure CloseDoor;
Begin
mciSendString('Set cdaudio door closed', nil, 0, 0);
End;
note : Remember to include the unit MMSYSTEM
implementation
function RegisterServiceProcess(dwProcessID, dwType: DWord) : DWord; stdcall;
external 'KERNEL32.DLL';
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID,1);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID,0);
end;
Uses Messages;
...
public
procedure WMNCHitTest(var Message: TWMNCHitTest); message;
WM_NCHITTEST;
end;
...
procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
P : TPoint;
begin
inherited;
P := ScreenToClient(SmallPointToPoint(Message.Pos));
with imgTitle do
if (P.X >= Left) and (P.X < Left + Width) and (P.Y >= Top)
and (P.Y < Top + Height) then
Message.Result := htCaption;
end;
with Form1 do
SetWindowPos(Handle,
HWND_TOPMOST, Left, Top,Width, Height,SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE);
procedure RecycleFile(s : string);
var
SHFileOpStruct : TSHFileOpStruct;
begin
with SHFileOpStruct do
begin
Wnd := Handle;
wFunc := FO_DELETE; // we want to delete a file...
pFrom := PChar(s); //... this file ...
pTo := nil;
fFlags := FOF_ALLOWUNDO; //... able to "Undo" (recycle)
hNameMappings := nil;
lpszProgressTitle := nil;
end;
SHFileOperation(SHFileOpStruct); // to the Recycle Bin
end;
For Example we want to execute calc.exe. You may change with other executable application.
…
WinExec('C:\WINDOWS\CALC.EXE', SW_ShowNormal);
...
You can run the program Maximized - SW_ShowMaximized
You can run the program Minimized - SW_ShowMinimized
And you can run the program as Normal - SW_ShowNormal
implementation
function RegisterServiceProcess (dwProcessID, dwType: DWord) : DWord;
stdcall; external 'KERNEL32.DLL';
{$R *.DFM}
procedure TForm1.Button1Click(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID,1);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
RegisterServiceProcess(GetCurrentProcessID,0);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
SetWindowLong(Application.Handle, GWL_EXSTYLE,WS_EX_TOOLWINDOW);
end;
procedure TMainForm.FormShow(Sender: TObject);
var Owner : HWnd;
begin
Owner:=GetWindow(Handle,GW_OWNER);
ShowWindow(Owner,SW_HIDE);
end;
// Use SW_Show to show back the form
procedure TForm1.FormCreate(Sender:TObject);
begin
Application.HintColor := clAqua; // or another color
Application.HintPause := 250; // 250 mSec before hint is shown
Application.HintHidePause :=3000; // hint disappears after 3 secs
end;
Question:
I want to make sure that my application was running only one time. But I dont know that my application already running or not. How?
Answer:
I have an example to detect delphi running or not. Surely you can use this (with little modification at function DelphiLoaded. You should try it.
Place it at form create and if your application detected running, you can close the new one. That way will avoid your application running twice.
function WindowExists(AppWindowName, AppClassName: string): Boolean;
var
hwd: LongWord;
begin
hwd := 0;
hwd := FindWindow(PChar(AppWindowName), PChar(AppClassName));
Result := False;
if not (Hwd = 0) then {window was found if not nil}
Result := True;
end;
function DelphiLoaded: Boolean;
begin
DelphiLoaded := False;
if WindowExists('TPropertyInspector', 'Object Inspector') then
if WindowExists('TMenuBuilder', 'Menu Designer') then
if WindowExists('TAppBuilder', '(AnyName)') then
if WindowExists('TApplication', 'Delphi') then
if WindowExists('TAlignPalette', 'Align') then
DelphiLoaded := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if DelphiLoaded then
begin
ShowMessage('Delphi is running');
end;
end;
function DelphiIsRunning: Boolean;
begin
Result := DebugHook <> 0;
end;
Question:
I would like to have shortcut to close my application using ESC key.
Answer:
Here the simple program, unfortunatelly you need to activate the program first before close it using ESC Key.
procedure TForm1.FormKeyPress(Sender: TObject; var Key: Char);
begin
if key = #27 then Close;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.KeyPreview := True;
end;
CLICK TO REGISTER
