Using the following code to let the player move in a game works. However, it doesn't really work the way we want. The problem is that when the player, for example, holds down the left arrow key and then fires, then the left movement will stop because another key than left is sent to the FormKeyDown() procedure. This will result in a nearly unplayable game in most cases.
procedure TForm1.FormKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
case Key of
vk_left : Dec(x);
vk_right : Inc(x);
vk_up : Dec(y);
vk_down : Inc(x);
vk_space : BulletFired; // call to another procedure
end;
end;
What we need is to detect key presses without interrupting already present keys which are down. The solution for this is to keep a state of each key. This is done with the following global variables.
var
movingUp : boolean;
movingDown : boolean;
movingRight : boolean;
movingLeft : boolean;
Now, instead of triggering the result directly (i.e. increasing/decreasing x/y position) we use the FormKeyDown() and FormKeyUp() procedures to toggle the state of each key. In this way, multiple keys may be down at once (for example the user may move up and right (diagonally) the same time as he presses fire).
FormKeyDown sets respectively state to True. Because someone can't move both up AND down at the same time the "opposite" key has to be set to False.
procedure TForm1.FormKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
case Key of
vk_left:
begin
movingLeft := True;
movingRight := False;
end;
vk_right:
begin
movingLeft := False;
movingRight := True;
end;
vk_up:
begin
movingUp := True;
movingDown := False;
end;
vk_down:
begin
movingUp := False;
movingDown := True;
end;
vk_space: BulletFired;
end;
end;
When a key is released the state is set to False in the FormKeyUp procedure.
procedure TForm1.FormKeyUp(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
case Key of
vk_left : movingLeft := False;
vk_right : movingRight := False;
vk_up : movingUp := False;
vk_down : movingDown := False;
end;
end;
The actual moving of the player is then performed from the game loop (Application.OnIdle for example) depending on each state. This is also the place to check to see if the player doesn't move out of bounds or collide into anything else.
procedure TForm1.MovePlayer;
if movingUp then Dec(y);
if movingDown then Inc(y);
if movingLeft then Dec(x);
if movingRight then Inc(x);
end;
This article was an example of how it may be done. I've tried to make it as general as possible so it shouldn't be a problem to apply this to a project, no matter if it's a jump'n run, racing or a shoot'em up game.
(more than one year later...)
As commented below, there is also another approach of doing this by using GetKeyState. The reason for the above, quite lenghty, solution is basically that I didn't know of GetKeyState when I wrote it more than one year ago. Therefore I do this little rewrite and add the GetKeyState solution.
Simply get rid of all the code above, and just replace the MovePlayer procedure with this code:
procedure TMainForm.MovePlayer;
begin
if (GetKeyState(VK_UP) and $80) = $80 then
Dec(y);
if (GetKeyState(VK_DOWN) and $80) = $80 then
Inc(y);
if (GetKeyState(VK_LEFT) and $80) = $80 then
Dec(x);
if (GetKeyState(VK_RIGHT) and $80) = $80 then
Inc(x);
end;
How to use the keyboard as input for games - Delphi
How to send keystrokes to another application (a better one) -Delphi
Found another unit which has exactly the same functionality as the SendKeys method of VB. The Code was written by Ken Henderson, email:khen@compuserve.com.
Begin of listing
======================================================================
(*
SendKeys routine for 32-bit Delphi.
Written by Ken Henderson
Copyright (c) 1995 Ken Henderson email:khen@compuserve.com
This unit includes two routines that simulate popular Visual Basic
routines: Sendkeys and AppActivate. SendKeys takes a PChar
as its first parameter and a boolean as its second, like so:
SendKeys('KeyString', Wait);
where KeyString is a string of key names and modifiers that you want
to send to the current input focus and Wait is a boolean variable or value
that indicates whether SendKeys should wait for each key message to be
processed before proceeding. See the table below for more information.
AppActivate also takes a PChar as its only parameter, like so:
AppActivate('WindowName');
where WindowName is the name of the window that you want to make the
current input focus.
SendKeys supports the Visual Basic SendKeys syntax, as documented below.
Supported modifiers:
+ = Shift
^ = Control
% = Alt
Surround sequences of characters or key names with parentheses in order to
modify them as a group. For example, '+abc' shifts only 'a', while '+(abc)' shifts
all three characters.
Supported special characters
~ = Enter
( = Begin modifier group (see above)
) = End modifier group (see above)
{ = Begin key name text (see below)
} = End key name text (see below)
Supported characters:
Any character that can be typed is supported. Surround the modifier keys
listed above with braces in order to send as normal text.
Supported key names (surround these with braces):
BKSP, BS, BACKSPACE
BREAK
CAPSLOCK
CLEAR
DEL
DELETE
DOWN
END
ENTER
ESC
ESCAPE
F1
F2
F3
F4
F5
F6
F7
F8
F9
F10
F11
F12
F13
F14
F15
F16
HELP
HOME
INS
LEFT
NUMLOCK
PGDN
PGUP
PRTSC
RIGHT
SCROLLLOCK
TAB
UP
Follow the keyname with a space and a number to send the specified key a
given number of times (e.g., {left 6}).
*)
unit sndkey32;
interface
Uses SysUtils, Windows, Messages;
Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
function AppActivate(WindowName : PChar) : boolean;
{Buffer for working with PChar's}
const
WorkBufLen = 40;
var
WorkBuf : array[0..WorkBufLen] of Char;
implementation
type
THKeys = array[0..pred(MaxLongInt)] of byte;
var
AllocationSize : integer;
(*
Converts a string of characters and key names to keyboard events and
passes them to Windows.
Example syntax:
SendKeys('abc123{left}{left}{left}def{end}456{left 6}ghi{end}789', True);
*)
Function SendKeys(SendKeysString : PChar; Wait : Boolean) : Boolean;
type
WBytes = array[0..pred(SizeOf(Word))] of Byte;
TSendKey = record
Name : ShortString;
VKey : Byte;
end;
const
{Array of keys that SendKeys recognizes.
If you add to this list, you must be sure to keep it sorted alphabetically
by Name because a binary search routine is used to scan it.}
MaxSendKeyRecs = 41;
SendKeyRecs : array[1..MaxSendKeyRecs] of TSendKey =
(
(Name:'BKSP'; VKey:VK_BACK),
(Name:'BS'; VKey:VK_BACK),
(Name:'BACKSPACE'; VKey:VK_BACK),
(Name:'BREAK'; VKey:VK_CANCEL),
(Name:'CAPSLOCK'; VKey:VK_CAPITAL),
(Name:'CLEAR'; VKey:VK_CLEAR),
(Name:'DEL'; VKey:VK_DELETE),
(Name:'DELETE'; VKey:VK_DELETE),
(Name:'DOWN'; VKey:VK_DOWN),
(Name:'END'; VKey:VK_END),
(Name:'ENTER'; VKey:VK_RETURN),
(Name:'ESC'; VKey:VK_ESCAPE),
(Name:'ESCAPE'; VKey:VK_ESCAPE),
(Name:'F1'; VKey:VK_F1),
(Name:'F10'; VKey:VK_F10),
(Name:'F11'; VKey:VK_F11),
(Name:'F12'; VKey:VK_F12),
(Name:'F13'; VKey:VK_F13),
(Name:'F14'; VKey:VK_F14),
(Name:'F15'; VKey:VK_F15),
(Name:'F16'; VKey:VK_F16),
(Name:'F2'; VKey:VK_F2),
(Name:'F3'; VKey:VK_F3),
(Name:'F4'; VKey:VK_F4),
(Name:'F5'; VKey:VK_F5),
(Name:'F6'; VKey:VK_F6),
(Name:'F7'; VKey:VK_F7),
(Name:'F8'; VKey:VK_F8),
(Name:'F9'; VKey:VK_F9),
(Name:'HELP'; VKey:VK_HELP),
(Name:'HOME'; VKey:VK_HOME),
(Name:'INS'; VKey:VK_INSERT),
(Name:'LEFT'; VKey:VK_LEFT),
(Name:'NUMLOCK'; VKey:VK_NUMLOCK),
(Name:'PGDN'; VKey:VK_NEXT),
(Name:'PGUP'; VKey:VK_PRIOR),
(Name:'PRTSC'; VKey:VK_PRINT),
(Name:'RIGHT'; VKey:VK_RIGHT),
(Name:'SCROLLLOCK'; VKey:VK_SCROLL),
(Name:'TAB'; VKey:VK_TAB),
(Name:'UP'; VKey:VK_UP)
);
{Extra VK constants missing from Delphi's Windows API interface}
VK_NULL=0;
VK_SemiColon=186;
VK_Equal=187;
VK_Comma=188;
VK_Minus=189;
VK_Period=190;
VK_Slash=191;
VK_BackQuote=192;
VK_LeftBracket=219;
VK_BackSlash=220;
VK_RightBracket=221;
VK_Quote=222;
VK_Last=VK_Quote;
ExtendedVKeys : set of byte =
[VK_Up,
VK_Down,
VK_Left,
VK_Right,
VK_Home,
VK_End,
VK_Prior, {PgUp}
VK_Next, {PgDn}
VK_Insert,
VK_Delete];
const
INVALIDKEY = $FFFF;
VKKEYSCANSHIFTON = $01;
VKKEYSCANCTRLON = $02;
VKKEYSCANALTON = $04;
UNITNAME = 'SendKeys';
var
UsingParens, ShiftDown, ControlDown, AltDown, FoundClose : Boolean;
PosSpace : Byte;
I, L : Integer;
NumTimes, MKey : Word;
KeyString : String[20];
procedure DisplayMessage(Message : PChar);
begin
MessageBox(0,Message,UNITNAME,0);
end;
function BitSet(BitTable, BitMask : Byte) : Boolean;
begin
Result:=ByteBool(BitTable and BitMask);
end;
procedure SetBit(var BitTable : Byte; BitMask : Byte);
begin
BitTable:=BitTable or Bitmask;
end;
Procedure KeyboardEvent(VKey, ScanCode : Byte; Flags : Longint);
var
KeyboardMsg : TMsg;
begin
keybd_event(VKey, ScanCode, Flags,0);
If (Wait) then While (PeekMessage(KeyboardMsg,0,WM_KEYFIRST, WM_KEYLAST, PM_REMOVE)) do begin
TranslateMessage(KeyboardMsg);
DispatchMessage(KeyboardMsg);
end;
end;
Procedure SendKeyDown(VKey: Byte; NumTimes : Word; GenUpMsg : Boolean);
var
Cnt : Word;
ScanCode : Byte;
NumState : Boolean;
KeyBoardState : TKeyboardState;
begin
If (VKey=VK_NUMLOCK) then begin
NumState:=ByteBool(GetKeyState(VK_NUMLOCK) and 1);
GetKeyBoardState(KeyBoardState);
If NumState then KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] and not 1)
else KeyBoardState[VK_NUMLOCK]:=(KeyBoardState[VK_NUMLOCK] or 1);
SetKeyBoardState(KeyBoardState);
exit;
end;
ScanCode:=Lo(MapVirtualKey(VKey,0));
For Cnt:=1 to NumTimes do
If (VKey in ExtendedVKeys)then begin
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY);
If (GenUpMsg) then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY or KEYEVENTF_KEYUP)
end else begin
KeyboardEvent(VKey, ScanCode, 0);
If (GenUpMsg) then KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
end;
Procedure SendKeyUp(VKey: Byte);
var
ScanCode : Byte;
begin
ScanCode:=Lo(MapVirtualKey(VKey,0));
If (VKey in ExtendedVKeys)then
KeyboardEvent(VKey, ScanCode, KEYEVENTF_EXTENDEDKEY and KEYEVENTF_KEYUP)
else KeyboardEvent(VKey, ScanCode, KEYEVENTF_KEYUP);
end;
Procedure SendKey(MKey: Word; NumTimes : Word; GenDownMsg : Boolean);
begin
If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyDown(VK_SHIFT,1,False);
If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyDown(VK_CONTROL,1,False);
If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyDown(VK_MENU,1,False);
SendKeyDown(Lo(MKey), NumTimes, GenDownMsg);
If (BitSet(Hi(MKey),VKKEYSCANSHIFTON)) then SendKeyUp(VK_SHIFT);
If (BitSet(Hi(MKey),VKKEYSCANCTRLON)) then SendKeyUp(VK_CONTROL);
If (BitSet(Hi(MKey),VKKEYSCANALTON)) then SendKeyUp(VK_MENU);
end;
{Implements a simple binary search to locate special key name strings}
Function StringToVKey(KeyString : ShortString) : Word;
var
Found, Collided : Boolean;
Bottom, Top, Middle : Byte;
begin
Result:=INVALIDKEY;
Bottom:=1;
Top:=MaxSendKeyRecs;
Found:=false;
Middle:=(Bottom+Top) div 2;
Repeat
Collided:=((Bottom=Middle) or (Top=Middle));
If (KeyString=SendKeyRecs[Middle].Name) then begin
Found:=True;
Result:=SendKeyRecs[Middle].VKey;
end else begin
If (KeyString>SendKeyRecs[Middle].Name) then Bottom:=Middle
else Top:=Middle;
Middle:=(Succ(Bottom+Top)) div 2;
end;
Until (Found or Collided);
If (Result=INVALIDKEY) then DisplayMessage('Invalid Key Name');
end;
procedure PopUpShiftKeys;
begin
If (not UsingParens) then begin
If ShiftDown then SendKeyUp(VK_SHIFT);
If ControlDown then SendKeyUp(VK_CONTROL);
If AltDown then SendKeyUp(VK_MENU);
ShiftDown:=false;
ControlDown:=false;
AltDown:=false;
end;
end;
begin
AllocationSize:=MaxInt;
Result:=false;
UsingParens:=false;
ShiftDown:=false;
ControlDown:=false;
AltDown:=false;
I:=0;
L:=StrLen(SendKeysString);
If (L>AllocationSize) then L:=AllocationSize;
If (L=0) then Exit;
While (I
case SendKeysString[I] of
'(' : begin
UsingParens:=True;
Inc(I);
end;
')' : begin
UsingParens:=False;
PopUpShiftKeys;
Inc(I);
end;
'%' : begin
AltDown:=True;
SendKeyDown(VK_MENU,1,False);
Inc(I);
end;
'+' : begin
ShiftDown:=True;
SendKeyDown(VK_SHIFT,1,False);
Inc(I);
end;
'^' : begin
ControlDown:=True;
SendKeyDown(VK_CONTROL,1,False);
Inc(I);
end;
'{' : begin
NumTimes:=1;
If (SendKeysString[Succ(I)]='{') then begin
MKey:=VK_LEFTBRACKET;
SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
SendKey(MKey,1,True);
PopUpShiftKeys;
Inc(I,3);
Continue;
end;
KeyString:='';
FoundClose:=False;
While (I<=L) do begin
Inc(I);
If (SendKeysString[I]='}') then begin
FoundClose:=True;
Inc(I);
Break;
end;
KeyString:=KeyString+Upcase(SendKeysString[I]);
end;
If (Not FoundClose) then begin
DisplayMessage('No Close');
Exit;
end;
If (SendKeysString[I]='}') then begin
MKey:=VK_RIGHTBRACKET;
SetBit(Wbytes(MKey)[1],VKKEYSCANSHIFTON);
SendKey(MKey,1,True);
PopUpShiftKeys;
Inc(I);
Continue;
end;
PosSpace:=Pos(' ',KeyString);
If (PosSpace<>0) then begin
NumTimes:=StrToInt(Copy(KeyString,Succ(PosSpace),Length(KeyString)-PosSpace));
KeyString:=Copy(KeyString,1,Pred(PosSpace));
end;
If (Length(KeyString)=1) then MKey:=vkKeyScan(KeyString[1])
else MKey:=StringToVKey(KeyString);
If (MKey<>INVALIDKEY) then begin
SendKey(MKey,NumTimes,True);
PopUpShiftKeys;
Continue;
end;
end;
'~' : begin
SendKeyDown(VK_RETURN,1,True);
PopUpShiftKeys;
Inc(I);
end;
else begin
MKey:=vkKeyScan(SendKeysString[I]);
If (MKey<>INVALIDKEY) then begin
SendKey(MKey,1,True);
PopUpShiftKeys;
end else DisplayMessage('Invalid KeyName');
Inc(I);
end;
end;
end;
Result:=true;
PopUpShiftKeys;
end;
{AppActivate
This is used to set the current input focus to a given window using its
name. This is especially useful for ensuring a window is active before
sending it input messages using the SendKeys function. You can specify
a window's name in its entirety, or only portion of it, beginning from
the left.
}
var
WindowHandle : HWND;
function EnumWindowsProc(WHandle: HWND; lParam: LPARAM): BOOL; export; stdcall;
const
MAX_WINDOW_NAME_LEN = 80;
var
WindowName : array[0..MAX_WINDOW_NAME_LEN] of char;
begin
{Can't test GetWindowText's return value since some windows don't have a title}
GetWindowText(WHandle,WindowName,MAX_WINDOW_NAME_LEN);
Result := (StrLIComp(WindowName,PChar(lParam), StrLen(PChar(lParam))) <> 0);
If (not Result) then WindowHandle:=WHandle;
end;
function AppActivate(WindowName : PChar) : boolean;
begin
try
Result:=true;
WindowHandle:=FindWindow(nil,WindowName);
If (WindowHandle=0) then EnumWindows(@EnumWindowsProc,Intege (PChar(WindowName)));
If (WindowHandle<>0) then begin
SendMessage(WindowHandle, WM_SYSCOMMAND, SC_HOTKEY, WindowHandle);
SendMessage(WindowHandle, WM_SYSCOMMAND, SC_RESTORE, WindowHandle);
end else Result:=false;
except
on Exception do Result:=false;
end;
end;
end.
======================================================================
End of listing
Try creating a new unit and paste the code above in it. The comments in the unit explain how to use it. In Holland we would say: "Beter goed gejat dan slecht verzonnen"
Adding Application or Ports to the Windows Firewall - Delphi
//Don't forget to add ActiveX and ComObj in your uses statement.
Const
NET_FW_PROFILE_DOMAIN = 0;
NET_FW_PROFILE_STANDARD = 1;
NET_FW_IP_VERSION_ANY = 2;
NET_FW_IP_PROTOCOL_UDP = 17;
NET_FW_IP_PROTOCOL_TCP = 6;
NET_FW_SCOPE_ALL = 0;
NET_FW_SCOPE_LOCAL_SUBNET = 1;
procedure addPortToFirewall(EntryName:string;PortNumber:Cardinal);
var
fwMgr,port:OleVariant;
profile:OleVariant;
begin
fwMgr := CreateOLEObject('HNetCfg.FwMgr');
profile := fwMgr.LocalPolicy.CurrentProfile;
port := CreateOLEObject('HNetCfg.FWOpenPort');
port.Name := EntryName;
port.Protocol := NET_FW_IP_PROTOCOL_TCP;
port.Port := PortNumber;
port.Scope := NET_FW_SCOPE_ALL;
port.Enabled := true;
profile.GloballyOpenPorts.Add(port);
end;
procedure addApplicationToFirewall(EntryName:string;ApplicationPathAndExe:string);
var
fwMgr,app,port:OleVariant;
profile:OleVariant;
begin
fwMgr := CreateOLEObject('HNetCfg.FwMgr');
profile := fwMgr.LocalPolicy.CurrentProfile;
app := CreateOLEObject('HNetCfg.FwAuthorizedApplication');
app.ProcessImageFileName := ApplicationPathAndExe;
app.Name := EntryName;
app.Scope := NET_FW_SCOPE_ALL;
app.IpVersion := NET_FW_IP_VERSION_ANY;
app.Enabled :=true;
profile.AuthorizedApplications.Add(app);
end;
//more things you can see at this Address: http://msdn2.microsoft.com/en-us/library/aa366415.aspx
NOTE: If you application doesn't initialize any activex objects you will also need to call CoInitialize(nil); before using the firewall functions and CoUninitialize; at the end.
How to detect a program that Not Responding? - Delphi
function IsHung(theWindow: Hwnd; timeOut: LongInt): Boolean;
var
dwResult: DWord;
begin
Result:= SendMessageTimeOut(theWindow, WM_NULL, 0, 0 ,
SMTO_ABORTIFHUNG or SMTO_BLOCK, timeOut, dwResult) <> 0;
end;
you can use FindWindow() function to get Handle of Window.
timOut is in Miliseconds.
Execute screensaver, then force execute your application at the same time
function KillScreenSaverWndProc(hwndx: HWND; lParamx: LPARAM): boolean;
begin
PostMessage(hwndx, WM_CLOSE, 0, 0);
Result := true;
end;
:
var
osversioninfo: TOSVersionInfo;
hssWnd: HWND;
hDeskWnd: HDESK;
begin
osversioninfo.dwOSVersionInfoSize := sizeof(osversioninfo);
GetVersionEx(osversioninfo);
case osversioninfo.dwPlatformId of
VER_PLATFORM_WIN32_WINDOWS:
begin
hssWnd := FindWindow('WindowsScreenSaverClass', nil);
if hwwWnd <> 0 then
PostMessage(hsswnd, WM_CLOSE, 0, 0);
end;
VER_PLATFORM_WIN32_NT:
begin
hDeskWnd := OpenDesktop(
'Screen-saver',
0,
false,
DESKTOP_READOBJECTS or DESKTOP_WRITEOBJECTS
);
if hDeskWnd <> 0 then
begin
EnumDesktopWindows(hDeskWnd, TFNWndEnumProc(@KillScreenSaverWndProc), 0);
CloseDesktop(hDeskWnd);
end
end;
end;
end;
Send characters to another control (in any application)
There are several methods to send keystrokes or characters to a WinControl. The SetKeyboardState requires the control to have the focus but can send more (esp. special) keys.
The use of WM_CHAR message enables you to send characters even to a hidden control unless you have found out the handle of it (there are a couple of ways to find out a controls handle).
Once you've got it, you can send messages to it.
I'm using this method for a little tool to "type" certain frequently used phrases while posting to newsgroups.
I hardcoded the handle of the edit control of my favorite newsreader and now I have a small and handy tool to type messages faster than ever.
// === code starts here ===
procedure SendMsg(const h: HWND; const s: string);
var
i: integer;
begin
if h = 0 then
Exit;
if Length(s) = 0 then
Exit;
for i:= 1 to Length(s) do
begin
if Ord(s[i]) in [9, 13, 32..254] then
SendMessage(h, WM_CHAR, Ord(s[i]), 0);
end;
end;
// === code ends here ===
How to find out if CAPS LOCK is on? b - Delphi
function IsCapsLockOn : Boolean;
begin
Result := 0 <> (GetKeyState(VK_CAPITAL) and $01);
end;
Changing the screen resolution - Delphi
To change the screen resolution you can use the following function
which is a wrapper for the Windows API ChangeDisplaySettings. The
function takes the desired width and height as parameters and returns
the return value of ChangeDisplaySettings (see the documentation for
more datails).
function SetScreenResolution(Width, Height: integer): Longint;
var
DeviceMode: TDeviceMode;
begin
with DeviceMode do begin
dmSize := SizeOf(TDeviceMode);
dmPelsWidth := Width;
dmPelsHeight := Height;
dmFields := DM_PELSWIDTH or DM_PELSHEIGHT;
end;
Result := ChangeDisplaySettings(DeviceMode, CDS_UPDATEREGISTRY);
end;
You can use ChangeDisplaySettings to change other properties of the
display like the color depth and the display frequency.
Sample call
-----------
In the following example first we get the current screen resolution
before setting it to 800x600, and then we restore it calling
SetScreenResolution again.
var
OldWidth, OldHeight: integer;
procedure TForm1.Button1Click(Sender: TObject);
begin
OldWidth := GetSystemMetrics(SM_CXSCREEN);
OldHeight := GetSystemMetrics(SM_CYSCREEN);
SetScreenResolution(800, 600);
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
SetScreenResolution(OldWidth, OldHeight);
end;
Show Windows properties window - Delphi
This function uses Shell API
The function:
function VisaEgenskaper(hWndOwner: HWND; const FileName: string): Boolean;
var Info: TShellExecuteInfo;
begin
{ Fill in the SHELLEXECUTEINFO structure }
with Info do
begin
cbSize := SizeOf(Info);
fMask := SEE_MASK_NOCLOSEPROCESS or
SEE_MASK_INVOKEIDLIST or
SEE_MASK_FLAG_NO_UI;
wnd := hWndOwner;
lpVerb := 'properties';
lpFile := pChar(FileName);
lpParameters := nil;
lpDirectory := nil;
nShow := 0;
hInstApp := 0;
lpIDList := nil;
end;
{ Call Windows to display the properties dialog. }
Result := ShellExecuteEx(@Info);
end;
Call the function with this line:
VisaEgenskaper(Application.Handle, 'C:\Thomas.txt');
Accessing the Windows Registry - Delphi
What is the Registry?
---------------------
It is where Windows stores many of its configuration options and also allows applications to access this data as well as save their own data. If you want to take a look at the registry, just execute the REGEDIT.EXE application located in the Windows directory. Be careful not to change anything or you could end up ruining your installation! Now, the data in the registry is stored in a tree structure. There are many roots (many trees):
HKEY_CLASSES_ROOT
HKEY_CURRENT_USER
HKEY_LOCAL_MACHINE
HKEY_USERS
HKEY_PERFORMANCE_DATA
HKEY_CURRENT_CONFIG
HKEY_DYN_DATA
Each root can have values and keys. The values are data stored under item names (right panel of RegEdit). Keys can have values and other keys, forming a tree structure (left panel of RegEdit).
For example, the tree HKEY_CURRENT_USER has many keys, like AppEvents, Control Panel, Identities, Network, Software, etc. Each key may have sub-keys. For example, Control Panel has some sub-keys, like Accessibility, Appearance, Colors, Cursors, Desktop, International, etc. All keys have at least one value (the first value in the right panel of RegEdit), which is the default value (the name of the value is the empty string), not necessarily set. A key may have more values. For example, let's see the key Control Panel\Colors under HKEY_CURRENT_USER. Appart from the default value, it has values like ActiveBorder, ActiveTitle, AppWorkspace, Background, etc. In turn, each "value" has a "data" (the actual value, sort to speak). For example, the data of the value ActiveTitle would be "0 0 128" (may be different if you are not using the standard Windows colors).
TRegistry
---------
Before getting into GetRegistryData and SetRegistryData, let's see how we would accomplish the same tasks the hard way, using TRegistry.
The TRegistry class is declared in the Registry unit, so you will have to add this unit to the Uses clause of the unit or program where you want to use it. To access a value in the registry, first you should create an object of this class, assign the root to its RootKey property (the values are defined in the Windows unit) and then try to open a key with the OpenKey function method, which will return True if successful. Then you can read (with the ReadXxxx functions) or write (with the WriteXxxx procedures) the values of the open key and, after that, you should close the key with CloseKey. When you are done with the registry, you should free the registry object you created. Let's see an example of how to obtain the name of the processor in our computer:
procedure TForm1.Button1Click(Sender: TObject);
var
Reg: TRegistry;
begin
Reg := TRegistry.Create;
Reg.RootKey := HKEY_LOCAL_MACHINE;
if Reg.OpenKey('\Hardware\Description\System'
+ '\CentralProcessor\0', False) then begin
ShowMessage(Reg.ReadString('Identifier'));
Reg.CloseKey;
end; // if
Reg.Free;
end;
You can see another example in the article Determining the associated application. Of course, there are many more things you can do with the registry, like creating and deleting keys and values...
The TRegistryIniFile class makes it simpler for applications to write and read their configuration information to and from the registry, while TRegistry operates at a lower level.
GetRegistryData
---------------
To simplify reading a data value from the registry you can use the following function that can read any data type from the registry and returns it as a variant (string or integer). The function performs exception handling.
uses Registry;
function GetRegistryData(RootKey: HKEY; Key,
Value: string): variant;
var
Reg: TRegistry;
RegDataType: TRegDataType;
DataSize, Len: integer;
s: string;
label cantread;
begin
Reg := nil;
try
Reg := TRegistry.Create(KEY_QUERY_VALUE);
Reg.RootKey := RootKey;
if Reg.OpenKeyReadOnly(Key) then begin
try
RegDataType := Reg.GetDataType(Value);
if (RegDataType = rdString) or
(RegDataType = rdExpandString) then
Result := Reg.ReadString(Value)
else if RegDataType = rdInteger then
Result := Reg.ReadInteger(Value)
else if RegDataType = rdBinary then begin
DataSize := Reg.GetDataSize(Value);
if DataSize = -1 then
raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
SetLength(s, DataSize);
Len := Reg.ReadBinaryData(Value, PChar(s)^, DataSize);
if Len <> DataSize then
raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
Result := s;
end else
raise Exception.Create(SysErrorMessage(ERROR_CANTREAD));
except
s := ''; // Deallocates memory if allocated
Reg.CloseKey;
raise;
end;
Reg.CloseKey;
end else
raise Exception.Create(SysErrorMessage(GetLastError));
except
Reg.Free;
raise;
end;
Reg.Free;
end;
Sample Call:
ShowMessage(GetRegistryData(HKEY_LOCAL_MACHINE,
'\Hardware\Description\System\CentralProcessor\0', 'Identifier'));
SetRegistryData
---------------
To simplify writing a data value to the registry you can use the following procedure that can write any data type to the registry. The procedure performs exception handling.
uses Registry;
procedure SetRegistryData(RootKey: HKEY; Key, Value: string;
RegDataType: TRegDataType; Data: variant);
var
Reg: TRegistry;
s: string;
begin
Reg := nil;
try
Reg := TRegistry.Create(KEY_WRITE);
Reg.RootKey := RootKey;
if Reg.OpenKey(Key, True) then begin
try
if RegDataType = rdUnknown then
RegDataType := Reg.GetDataType(Value);
if RegDataType = rdString then
Reg.WriteString(Value, Data)
else if RegDataType = rdExpandString then
Reg.WriteExpandString(Value, Data)
else if RegDataType = rdInteger then
Reg.WriteInteger(Value, Data)
else if RegDataType = rdBinary then begin
s := Data;
Reg.WriteBinaryData(Value, PChar(s)^, Length(s));
end else
raise Exception.Create(SysErrorMessage(ERROR_CANTWRITE));
except
Reg.CloseKey;
raise;
end;
Reg.CloseKey;
end else
raise Exception.Create(SysErrorMessage(GetLastError));
except
Reg.Free;
raise;
end;
Reg.Free;
end;
Sample Call:
SetRegistryData(HKEY_LOCAL_MACHINE,
'\Software\Microsoft\Windows\CurrentVersion',
'RegisteredOrganization', rdString, 'Latium Software');
logged in as administator - Delphi
const
SECURITY_NT_AUTHORITY: TSIDIdentifierAuthority =
(Value: (0, 0, 0, 0, 0, 5));
SECURITY_BUILTIN_DOMAIN_RID = $00000020;
DOMAIN_ALIAS_RID_ADMINS = $00000220;
function IsAdmin: Boolean;
var
hAccessToken: THandle;
ptgGroups: PTokenGroups;
dwInfoBufferSize: DWORD;
psidAdministrators: PSID;
x: Integer;
bSuccess: BOOL;
begin
Result := False;
bSuccess := OpenThreadToken(GetCurrentThread, TOKEN_QUERY, True,
hAccessToken);
if not bSuccess then
begin
if GetLastError = ERROR_NO_TOKEN then
bSuccess := OpenProcessToken(GetCurrentProcess, TOKEN_QUERY,
hAccessToken);
end;
if bSuccess then
begin
GetMem(ptgGroups, 1024);
bSuccess := GetTokenInformation(hAccessToken, TokenGroups,
ptgGroups, 1024, dwInfoBufferSize);
CloseHandle(hAccessToken);
if bSuccess then
begin
AllocateAndInitializeSid(SECURITY_NT_AUTHORITY, 2,
SECURITY_BUILTIN_DOMAIN_RID, DOMAIN_ALIAS_RID_ADMINS,
0, 0, 0, 0, 0, 0, psidAdministrators);
{$R-}
for x := 0 to ptgGroups.GroupCount - 1 do
if EqualSid(psidAdministrators, ptgGroups.Groups[x].Sid) then
begin
Result := True;
Break;
end;
{$R+}
FreeSid(psidAdministrators);
end;
FreeMem(ptgGroups);
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
if isAdmin then
begin
ShowMessage('Logged in as Administrator');
end;
end;
How to set the current screensaver - Delphi
The following code sets up your desired screensave then shows it. For actual use this code needs to be changed to suite your needs i.e. remove ShowMessage dialogs, change name of screensaver, change timeout value and remove actual testing section.
Tested under Windows XP but should work with earlier versions of Windows
program SetupDefaultScrnSaver;
uses
Windows, SysUtils, Forms, Dialogs, Registry;
const
{ from Windows.pas }
SPI_SETSCREENSAVEACTIVE = 17;
SPIF_SENDWININICHANGE = 2;
SPI_SETSCREENSAVETIMEOUT = 15;
{ from Messages.pas }
WM_SYSCOMMAND = $0112;
{ From Project JEDI JCL library
http://www.delphi-jedi.org/Jedi:CODELIBJCL:22798 }
function GetWindowsSysFolder: string;
procedure StrResetLength(var S: AnsiString);
begin
SetLength(S, StrLen(PChar(S)));
end;
var
Required: Cardinal;
begin
Result := '';
Required := GetSystemDirectory(nil, 0);
if Required <> 0 then
begin
SetLength(Result, Required);
GetSystemDirectory(PChar(Result), Required);
StrResetLength(Result) ;
end;
end;
function SetScreenSave(const Name: string; Const TimeOut: Integer = 30):Boolean;
const
SixtySeconds = 60 ;
var
Reg:TRegistry ;
begin
if not FileExists(Name) then
begin
ShowMessage('ScreenSaver "' + Name + '" not located') ;
exit ;
end ;
Reg := TRegistry.Create ;
Reg.RootKey := HKEY_CURRENT_USER ;
try
with Reg do
begin
if OpenKey('Control Panel\Desktop',False) then
begin
WriteString('SCRNSAVE.EXE', Name) ;
WriteString('ScreenSaverIsSecure','1') ;
CloseKey ;
end else
begin
Result := False ;
exit ;
end ;
end ;
finally
Reg.Free ;
end ;
SystemParametersInfo(SPI_SETSCREENSAVEACTIVE,1,nil,SPIF_SENDWININICHANGE);
SystemParametersInfo(SPI_SETSCREENSAVETIMEOUT,SixtySeconds * TimeOut,
nil,SPIF_SENDWININICHANGE);
Result := True ;
end;
begin
{ -=CHANGE THE SCREENSAVER NAME TO ONE YOU WANT THE USER TO HAVE=- }
if SetScreenSave(GetWindowsSysFolder + '\ss3dfo.scr') then begin
ShowMessage('Screensaver set, press OK to test (remember grace period)') ;
PostMessage(GetDesktopWindow, WM_SYSCOMMAND, SC_SCREENSAVE, 0);
end ;
end.
Making an application run automatically when Windows starts
One way is placing a direct access to the application in the Startup folder of Windows Start Menu. Alternatively, you can add a value under the appropriate key in the Windows Registry, as shown below:
procedure TForm1.Button1Click(Sender: TObject);
begin
SetRegistryData(HKEY_LOCAL_MACHINE,
'Software\Microsoft\Windows\CurrentVersion\Run',
Application.Title, rdString, Application.ExeName);
end;
NOTE: SetRegistryData has been featured in the article "Accessing the Windows Registry": http://www.delphi3000.com/articles/article_1575.asp
Instead of Application.Title you can write a string with a unique name for the application, and instead of Application.ExeName you can write the full path name of the application (as well as its command-line parameters if they are needed)
Hiding caption bars - Delphi
// Author : Digital Survivor [Esteban Rodríguez Nieto | José Plano]
// Email : plmad666@gmail.com | jose.plano@gmail.com
// Web site : www.ds-studioscom.ar
//---------------------------------------------------------------------------
We can use this example in the onCreate event:
Procedure TForm1.FormCreate (Sender : TObject);
Begin
SetWindowLong (Handle, GWL_STYLE, GetWindowLong (Handle, GWL_STYLE) AND NOT WS_CAPTION);
ClientHeight := Height;
End;
//---------------------------------------------------------------------------
Detecting CPU type - Delphi
//---------------------------------------------------------------------------
// Author : Digital Survivor [Esteban Rodríguez Nieto | José Plano]
// Email : plmad666@gmail.com | jose.plano@gmail.com
// Web site : www.ds-studios.com.ar
//---------------------------------------------------------------------------
{ Note: This code seems not to work in all machines. It's seems also not to work with all kinds of CPUs, but try it. It works for me... }
Unit CPUid;
Interface
Type
TCpuType = (cpu8086, cpu286, cpu386, cpu486, cpuPentium);
Function CpuType : TCpuType;
Function CpuTypeString : String;
Implementation
Uses
SysUtils;
Function CpuType : TCpuType; ASSEMBLER;
Asm
// 8086 CPU check
push ds
pushf
pop bx
mov ax, 0fffh
and ax, bx
push ax
popf
pushf
pop ax
and ax, 0f000h
cmp ax, 0f000h
mov ax, cpu8086
je @@End_CpuType
// 80286 CPU check
or bx, 0f000h
push bx
popf
pushf
pop ax
and ax, 0f000h
mov ax, cpu286
jz @@End_CpuType
// 386 CPU check
db 66h
pushf
db 66h
pop ax
db 66h
mov cx, ax
db 66h
xor ax, 0h
dw 0004h
db 66h
push ax
db 66h
popf
db 66h
pushf
db 66h
pop ax
db 66h
xor ax, cx
mov ax, cpu386
je @@End_CpuType
// 486 CPU check
db 66h
pushf
db 66h
pop ax
db 66h
mov cx, ax
db 66h
xor ax, 0h
dw 0020h
db 66h
push ax
db 66h
popf
db 66h
pushf
db 66h
pop ax
db 66h
xor ax, cx
mov ax, cpu486
je @@End_CpuType
// Pentium CPU check
db 66h
mov ax, 1
dw 0
db 66h
db 0Fh
db 0a2h
db 66h
and ax, 0F00H
dw 0
db 66h
shr ax, 8
sub ax, 1
@@End_CpuType:
pop ds
End;
Function CpuTypeString : String;
Var
Kind : TCpuType;
Begin
Kind := CpuType;
Case Kind Of
cpu8086 : Result := '8086';
cpu286 : Result := '286';
cpu386 : Result := '386';
cpu486 : Result := '486';
cpuPentium : Result := 'Pentium';
Else Result := Format ('P%d', [Ord (kind)]);
End;
End;
End.
Changing hard drive's icon under Windows XP - Delphi
This article shows that how can changing a driver icon in MyComputer under
WinXP. This modification is so different than Win9x and not easy.
As you know that you have so many articles that just change some settings
in the registry in D3K database, but the following registry codes are
undocumanted and you don't see it normally in XP Registry.
if you can want to change your hard driver icon then insert the following
code into Button1's OnClick event. I hope this be usefull for someone.
add Registry in USES clause
procedure TForm1.Button1Click(Sender: TObject);
var Reg: TRegistry;
begin
Reg := TRegistry.Create;
try
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey
('Software\Microsoft\Windows\CurrentVersion\Explorer\DriveIcons\', True);
{ True, because if a subkey named DriveIcons and/or DefaultIcon
does not exist, windows automatically creates it }
OpenKey('C\DefaultIcon\', True); // as default first drive C
// we are choosing empty field as default value
WriteString('', 'C:\YourIcons\Sample1.ico');
{ and icon file path or if dll file then
e.g 'c:\YourIcons\Icons.dll, 2' }
CloseKey;
end;
finally
Reg.Free;
end;
// if 2nd hard drive is present..
Reg := TRegistry.Create;
try
with Reg do
begin
RootKey := HKEY_LOCAL_MACHINE;
OpenKey
('Software\Microsoft\Windows\CurrentVersion\Explorer\DriveIcons\', True);
OpenKey('D\DefaultIcon\', True);
WriteString('', 'C:\YourIcons\Sample2.ico');
CloseKey;
end;
finally
Reg.Free;
end;
end;
in the same way, you can write these techniques for another drivers.
Now, hard drive's icon have been changed. Press F5 on the keyboard
or reboot for the changes to take effect.
Changing attributes of files - Delphi
To read a file's attributes, pass the filename to the FileGetAttr function, which returns the file attributes of a file.For example, add a TButton and TLabel components to the form and write the following code to the OnClick event of button.
var
attr:Integer;
s:string;
begin
attr:=FileGetAttr('c:\Autoexec.bat');
if(attr and faHidden)<>0 then s:='Hidden';
if(attr and faReadOnly)<>0 then s:=s+'Read-Only';
if(attr and faSysFile)<>0 then s:=s+'System';
if(attr and faArchive)<>0 then s:=s+'Archive';
Label1.Caption:=s;
---------------------------
To set a file's attributes, pass the name of the file and the attributes you want to the FileSetAttr function.Each attribute has a mnemonic name defined in the SysUtils unit. For example, to set a file's system attribute, you would do the following:
Attributes := Attributes or faSystem;
You can also set or clear several attributes at once. For example, the clear both the read-only file and hidden attributes:
Attributes := Attributes and not (faReadOnly or faHidden);
---------------------------
Furthermore,To change file's attribute, you can use the following return values.The routine can be simplified.
+----------------------------------+
| Return Value | Attribute of File |
+----------------------------------+
| 128 | Normal |
| 1 | Read Only |
| 2 | Hidden |
| 4 | System |
| 32 | Archive |
+--------------+-------------------+
Sample call: We use a code like the following:
FileSetAttr('C:\Autoexec.bat',2);{Hidden}
FileSetAttr('C:\Autoexec.bat',3);{Hidden and Read-Only.
FileGetAttr returns 3 value}
Get the next day of the month
NOTE: You need do add the unit "DateUtils" to the uses clause (where DayOfTheWeek is declared).
//----------------------------------------------------------------
type
TWeeks = (wFirst, wSecond, wThird, wFourth, wLast);
TWeekDays = (wdMonday, wdTuesday, wdWednesday, wdThursday,
wdFriday, wdSaturday, wdSunday);
//Examples:
//ShowMessage(DateTimeToStr(GetDayOfMonth(Now, wLast, wdTuesday)));
//ShowMessage(DateTimeToStr(GetDayOfMonth(Now, wFirst, wdSunday)));
function DaysPerMonth(AYear, AMonth: Integer): Integer;
const
DaysInMonth: array[1..12] of Integer =
(31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
begin
Result := DaysInMonth[AMonth];
if (AMonth = 2) and IsLeapYear(AYear) then Inc(Result); { leap-year Feb is special }
end;
function GetDayOfMonth(DT: TDateTime; Weeks: TWeeks; WeekDays: TWeekDays): TDateTime;
var
aDateTime: TDateTime;
aDayOfWeek, bDayOfWeek: Word;
AYear, AMonth, ADay: Word;
begin
DecodeDate(DT, AYear, AMonth, ADay);
aDateTime := EncodeDate(AYear, AMonth, 1); //Returns the 1st day of the month
//-DayOfTheWeek-
//1 - Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, 7 - Sunday
aDayOfWeek := DayOfTheWeek(aDateTime);
//-WeekDays-
//0 - Monday, Tuesday, Wednesday, Thursday, Friday, Saturday, 6 - Sunday
bDayOfWeek := Ord(WeekDays) +1;
if aDayOfWeek <= bDayOfWeek //The day we want is still yet to come
then ADay := (bDayOfWeek - aDayOfWeek)
else ADay := 7 - (aDayOfWeek - bDayOfWeek);
//-Weeks-
//0 - first, 1 - second, 2 - third, 3 - fourth, 4 - last
ADay := ADay + Ord(Weeks) * 7;
if Ord(Weeks) = 4 then
if (ADay+1 > DaysPerMonth(AYear, AMonth))
or ( (ADay+1 <= DaysPerMonth(AYear, AMonth))
and (bDayOfWeek <> DayOfTheWeek(EncodeDate(AYear, AMonth, ADay+1))) )
then ADay := ADay - 7;
Result := aDateTime + ADay;
end;
//----------------------------------------------------------------
I'm sure there are better ways to deal with this problem so please let me know if you happen to know any.
Make A System-Wide Shorcut Key !! - Delphi
Try This Code...........
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
protected
procedure hotykey(var msg:TMessage); message WM_HOTKEY;
end;
var
Form1: TForm1;
id,id2:Integer;
implementation
{$R *.DFM}
procedure TForm1.hotykey(var msg:TMessage);
begin
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=81) then
begin
ShowMessage('Ctrl + Q wurde gedrückt !');
end;
if (msg.LParamLo=MOD_CONTROL) and (msg.LParamHi=82) then
begin
ShowMessage('Ctrl + R wurde gedrückt !');
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
id:=GlobalAddAtom('hotkey');
RegisterHotKey(handle,id,mod_control,81);
id2:=GlobalAddAtom('hotkey2');
RegisterHotKey(handle,id2,mod_control,82);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
UnRegisterHotKey(handle,id);
UnRegisterHotKey(handle,id2);
end;
Preventing the user from closing a form - Delphi
To prevent the user from closing a form you need to disable the close
button in the title bar of a form and at the same time disable the
"Close" menu item in the form's system menu. This is done by calling
the EnableMenuItem API function (see the example below). Nonetheless,
the user can still close the form using the Alt+F4 key combination,
so we have to set the KeyPreview form property to True and write an
event handler for the OnKeyDown event to cancel out this hot key:
procedure TForm1.FormCreate(Sender: TObject);
var
hSysMenu: HMENU;
begin
hSysMenu := GetSystemMenu(Self.Handle, False);
if hSysMenu <> 0 then begin
EnableMenuItem(hSysMenu, SC_CLOSE,
MF_BYCOMMAND Or MF_GRAYED);
DrawMenuBar(Self.Handle);
end;
KeyPreview := True;
end;
procedure TForm1.FormKeyDown(Sender: TObject;
var Key: Word; Shift: TShiftState);
begin
if (Key = VK_F4) and (ssAlt in Shift) then
Key := 0;
end;
Display forms full screen
Covering the entire screen with a form is relatively easy to accomplish as shown below.
Component Download: ../article/2863/KG_FullScreen.zip
procedure TfrmMainForm.FormCreate(Sender: TObject);
begin
{ Position form }
Top := 0 ;
Left := 0 ;
{ Go full screen }
WindowState := wsmaximized;
ClientWidth := Screen.Width ;
ClientHeight := Screen.Height;
Refresh;
end;
If this is a typical form it will have borders which you might consider removing by setting BorderStyle property to bsNone as shown below.
procedure TfrmMainForm.FormCreate(Sender: TObject);
begin
{ Position form }
Top := 0 ;
Left := 0 ;
{ Go full screen }
BorderStyle := bsNone ;
WindowState := wsmaximized;
ClientWidth := Screen.Width ;
ClientHeight := Screen.Height;
Refresh;
end;
Sometimes the code shown above will go full screen but still display the Windows TaskBar, if this happens we can force the form on top using either SetForeGroundWindow or SetActiveWindow. From my testing it is best to use both if the problem persist.
procedure TfrmMainForm.FormCreate(Sender: TObject);
begin
{ Position form }
Top := 0 ;
Left := 0 ;
{ Go full screen }
BorderStyle := bsNone ;
WindowState := wsmaximized;
ClientWidth := Screen.Width ;
ClientHeight := Screen.Height;
Refresh;
SetForegroundWindow(Handle) ;
SetActiveWindow(Application.Handle) ;
end;
Other considerations (see attachment for code to address these items)
If the form is already in maximized window state the above code will not work.
Controlling the system menu commands as per above needs to be considered
Ghost items in the TaskBar after terminating your application.
Delphi makes it simple to cover the display screen but what if you need to duplicate the functionality in another programming language such as Microsoft Visual Basic? Well in this case you might want to learn the API methods (again see attachment).
Rotate an image by 90º
You have to create two images first. I'm sure anyone could convert this code to use just on image by using a TBitmap.
Procedure TurnImage(Src, Dst: TImage);
var x,y: integer;
begin
Dst.Width:= Src.Height; Dst.Height:= Src.Width;
For x:= 0 to Src.Width-1 do begin
For y:= 0 to Src.Height-1 do begin
Dst.Canvas.Pixels[(Src.Height-1)-y,x]:= Src.Canvas.Pixels[x,y];
end;
end;
end;
Inserting a .bmp file into your .exe
One problem with inserting a bitmap file into your .exe is that it makes your programs .exe larger, so it is a good idea if your
program uses small bitmap files.
The Delphi example below will work on any version of Delphi above Delphi 2.
First open an editor like Notepad.exe, for this example we will use a bitmap file called Picture.bmp
and this is the bitmap file we will insert into our programs .exe
(Make sure that there is a picture in your folder/directory named Picture.bmp.
If you do not have a picture already called Picture.bmp you can rename a different bitmap file so that it is called Picture.bmp)
Type these words into the text file:
ThePicture Bitmap "Picture.bmp"
Then save the text file as:
mybmp.rc
We will use BRCC32.exe that comes with Delphi and it should be in Delphi's Bin directory, to compile the file.
In order to use BRCC32.exe you have to use a DOS window, using DOS is not hard at all.
To run a DOS window, go to your TaskBar, click Start|Programs|MS-DOS Prompt
Whenever you use DOS all you have to do to get back to Windows (Your desktop) is type the word Exit, then press the Enter
key.
You should have your bitmap files and your .rc file in the same folder/directory.
So we will type this sentence in the DOS window:
C:\Delphi 3\Bin\Brcc32.exe C:\Delphi 3\bin\bmps\MyBmp.rc
The above paths may have to be changed to the place where you have Delphi installed and to the folder/directory where you
have saved your files for this example.
If this does not work or you get an error, you may not have Delphi in your computers path.
A way around this is for you to copy the BRCC32.exe and RW32CORE.DLL into your folder/directory that you are using,
then try again.
(The above files, BRCC32.exe and RW32CORE.DLL, may be different for different versions of Delphi)
Use Explorer or another File Manager and have a look in your directory, you should find that you have an extra file called
mybmp.RES.
Start Delphi, then start a new project (Application).
Look for {$R *.DFM} in Unit1 and add {$R MYBMP.RES} next to it.
Add a TImage component to your form and make its AutoSize property True.
Next drop a Button onto your Form, double-click on the Button and add this code:
Image1.Picture.Bitmap.LoadFromResourceName(hInstance, 'ThePicture');
Note we use 'ThePicture' to call the bitmap file.
Run the program and then click on the Button, you should see the image that you put into the resource file.
If you have to save the project before you can run it, save in in the same folder/directory where you have the resource (*.RES)
file.
Your complete unit should look like this:
unit Unit1;
interface
uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, ExtCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM} {$R MYBMP.RES}
procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Bitmap.LoadFromResourceName(hInstance, 'THEPICTURE');
end;
end.
Screencapture with animated gif support!
In may last year i promised to create a component which could
take screenshots and save them in a gif image, and here it
FINALLY is. :)
This component can be used in ANY kind of application, royalty
free with only 1 demand: credits!
==============================================================
Description:
This component can create screenshots of the screen (or
portions of the screen).
You can set a region of what you want to "photograph" by
calling the function
=> TtspScreenCapture.SetRegion(ARegion: TCaptureRegion)
After setting the region you must specify a capture mode.
there are 4 capturemodes:
- cmStillBitmap
- cmStillJPEG
- cmStillGIF
- cmMotionGIF
Now you can take a still image by calling the function
=> TtspScreenCapture.GetStillImage: TCaptureResult;
According to the chosen capture mode you can access the
screenshot in the proper TGraphic object:
=> TCaptureResult = record
VBitmap: TBitmap;
VJPEG: TJPEGImage;
VGIFImage: TGIFImage;
end;
With these objects you can save the images to wherever you want
them.
Motion gifs require a little different approach.
First you must set the capture mode to cmMotionGIF.
Accordingly you must set the interval in which a screenshot
should be taken by setting the property
=> TtspScreenCapture.MotionGifInterval: integer
This property is in milliseconds. (1 second = 1000 millisecond)
Everything is now ready for capturing.
To activate the capturing set the property
=> TtspScreenCapture.Active: boolean;
to true.
while capturing you can read the current GIFImage by calling the
function
=> TtspScreenCapture.GetMotionGif: TGIFImage;
To stop capturing set the Active property back to false.
The final Gif image is again accesible by calling the function
GetMotionGIF.
======================================================================
Benchmark:
The component also contains a function benchmark. this is a very simple
function which calculates how much frames can be captured in 10 seconds.
the result value is in captured frames per second (rounded).
=======================================================================
well, this wraps it up for now.
Good luck with using this component in your application!
Nevertheless i have 1 more thing to tell you:
1. DON'T forget to credit me in your application. You got this for free
so it would be quite fair to do this simple thing.
========================================================================
Have fun,
Christiaan ten Klooster
webmaster@tsp2000.tmfweb.nl
www.tsp2000.tmfweb.nl
check, if a directory is empty - Delphi
// Diese Funktion gibt true zurück, falls Directory ein leeres Verzeichnis ist.
// This function returns true if Directory is an empty directory.
function DirectoryIsEmpty(Directory: string): Boolean;
var
SR: TSearchRec;
i: Integer;
begin
Result := False;
FindFirst(IncludeTrailingPathDelimiter(Directory) + '*', faAnyFile, SR);
for i := 1 to 2 do
if (SR.Name = '.') or (SR.Name = '..') then
Result := FindNext(SR) <> 0;
FindClose(SR);
end;
// Beispiel:
// Example:
procedure TForm1.Button1Click(Sender: TObject);
begin
if DirectoryIsEmpty('C:\test') then
Label1.Caption := 'empty'
else
Label1.Caption := 'not empty';
end;
Show Windows properties window - Delphi
This function uses Shell API
The function:
function VisaEgenskaper(hWndOwner: HWND; const FileName: string): Boolean;
var Info: TShellExecuteInfo;
begin
{ Fill in the SHELLEXECUTEINFO structure }
with Info do
begin
cbSize := SizeOf(Info);
fMask := SEE_MASK_NOCLOSEPROCESS or
SEE_MASK_INVOKEIDLIST or
SEE_MASK_FLAG_NO_UI;
wnd := hWndOwner;
lpVerb := 'properties';
lpFile := pChar(FileName);
lpParameters := nil;
lpDirectory := nil;
nShow := 0;
hInstApp := 0;
lpIDList := nil;
end;
{ Call Windows to display the properties dialog. }
Result := ShellExecuteEx(@Info);
end;
Call the function with this line:
VisaEgenskaper(Application.Handle, 'C:\Thomas.txt');
Send a file to windows recycle bin - Delphi
Don't forget to add ShellAPI in your uses-group.
This is the function that does all the work:
function RecycleFile(sFileName: string): Boolean;
var
FOS: TSHFileOpStruct;
begin
FillChar(FOS, SizeOf(FOS), 0);
with FOS do
begin
wFunc := FO_DELETE; { Functions as FO_COPY also works.
pFrom := PChar(sFileName + #0);
pTo := { Only for FO_COPY }
fFlags := FOF_ALLOWUNDO; { Since we wan't to send the file the file to recycle bin }
end;
// Send the file
Result := (SHFileOperation(FOS) = 0);
end;
Call the function by using this line:
RecycleFile('E:\Test.exe');
Searching for a directory
//---------------------------------------------------------------------------
// Author : Digital Survivor [Esteban Rodríguez Nieto | José Plano]
// Email : plmad666@gmail.com | jose.plano@gmail.com
// Web site : www.ds-studios.com.ar
//---------------------------------------------------------------------------
The most simple way to view a complete list of drives and directories in the system is calling the function SelectDirectory included in the FileCtrl unit. This function shows Windows' standard "Search directory" dialog box. With it, we can search and select any directory of the system. The only problem I can find, is that we can't set the where this dialog box appears. Generaly appears in the right-bottom corner of the screen. If anyone know how to change this, please let me know. Good luck...
//---------------------------------------------------------------------------
Uses
FileCtrl;
Procedure BrowseClick;
Var
S : string;
Begin
S := '';
If SelectDirectory ('Select Directory', '', S) Then SetPath (S);
End;
Getting the icon of an application, library or document
---------------------
To get the icon of an application or document we can use this API
function (declared in the ShellAPI unit):
function ExtractAssociatedIcon(hInst: HINST; lpIconPath: PChar;
var lpiIcon: Word): HICON; stdcall;
* hInst: The application handle. This value is contained in the
predefined variable HInstance.
* lpIconPath: A pointer to a character buffer that should contain a
null terminated string with the full path name of the application,
library (DLL) or document. If it is a document, the function will
place there the full pathname of the associated application from
where the icon was extracted, so we should allocate a buffer large
enough.
* lpiIcon: The icon index (the first icon in the file has an index of
0). If lpIconPath specifies a document, then lpiIcon is set by the
function (that's why it is passed by reference) to the index
position of the actual icon taken from the associated executable
(defined in the file association).
Return value:
If the function fails, it returns 0. If it succeeds, it returns an
icon handle, which is an integer value Windows uses to identify the
allocated resource. It is not necessary to call the API DestroyIcon
to release the icon since it'll be deallocated automatically when the
application finishes, although you can do it if you want.
Sample call
-----------
Now, what do we do with the icon handle? Normally what we want is an
icon, namely and instance of the TIcon class. All we have to do is
create a TIcon object and assign this handle to its Handle property.
If later we assign the Handle property to another value, the previous
icon will be automatically be released. The same happens if the TIcon
object is freed. Here is an example that changes the icon of the form:
procedure TForm1.Button1Click(Sender: TObject);
var
IconIndex: word;
Buffer: array[0..2048] of char;
IconHandle: HIcon;
begin
StrCopy(@Buffer, 'C:\Windows\Help\Windows.hlp');
IconIndex := 0;
IconHandle := ExtractAssociatedIcon(HInstance, Buffer, IconIndex);
if IconHandle <> 0 then
Icon.Handle := IconHandle;
end;
GetAssociatedIcon
-----------------
Unfortunately, ExtractAssociatedIcon fails if the file does not exists
on disk, so we defined a procedure that gets the icon of a file
whether it exists or not, and can also get the small icon (ideal for
a TListView that can be shown in vsIcon or vsReport view styles). The
procedure receives three parameters: the filename and two pointers to
HICON (integer) variables: one for the large icon (32x32) and another
one for the small icon (16x16). Any of them can be nil if you don't
need one of these icons. The icons "returned" by the procedure must be
freed with the DestroyIcon API. This will be done automatically if you
assign the icon handle (HICON) to the Handle property of a TIcon object
(the icon will be released when this object gets freed or a new value
is assigned to it).
uses
Registry, ShellAPI;
type
PHICON = ^HICON;
procedure GetAssociatedIcon(FileName: TFilename;
PLargeIcon, PSmallIcon: PHICON);
// Gets the icons of a given file
var
IconIndex: word; // Position of the icon in the file
FileExt, FileType: string;
Reg: TRegistry;
p: integer;
p1, p2: pchar;
label
noassoc;
begin
IconIndex := 0;
// Get the extension of the file
FileExt := UpperCase(ExtractFileExt(FileName));
if ((FileExt <> '.EXE') and (FileExt <> '.ICO')) or
not FileExists(FileName) then begin
// If the file is an EXE or ICO and it exists, then
// we will extract the icon from this file. Otherwise
// here we will try to find the associated icon in the
// Windows Registry...
Reg := nil;
try
Reg := TRegistry.Create(KEY_QUERY_VALUE);
Reg.RootKey := HKEY_CLASSES_ROOT;
if FileExt = '.EXE' then FileExt := '.COM';
if Reg.OpenKeyReadOnly(FileExt) then
try
FileType := Reg.ReadString('');
finally
Reg.CloseKey;
end;
if (FileType <> '') and Reg.OpenKeyReadOnly(
FileType + '\DefaultIcon') then
try
FileName := Reg.ReadString('');
finally
Reg.CloseKey;
end;
finally
Reg.Free;
end;
// If we couldn't find the association, we will
// try to get the default icons
if FileName = '' then goto noassoc;
// Get the filename and icon index from the
// association (of form '"filaname",index')
p1 := PChar(FileName);
p2 := StrRScan(p1, ',');
if p2 <> nil then begin
p := p2 - p1 + 1; // Position of the comma
IconIndex := StrToInt(Copy(FileName, p + 1,
Length(FileName) - p));
SetLength(FileName, p - 1);
end;
end;
// Attempt to get the icon
if ExtractIconEx(pchar(FileName), IconIndex,
PLargeIcon^, PSmallIcon^, 1) <> 1 then
begin
noassoc:
// The operation failed or the file had no associated
// icon. Try to get the default icons from SHELL32.DLL
try // to get the location of SHELL32.DLL
FileName := IncludeTrailingBackslash(GetSystemDir)
+ 'SHELL32.DLL';
except
FileName := 'C:\WINDOWS\SYSTEM\SHELL32.DLL';
end;
// Determine the default icon for the file extension
if (FileExt = '.DOC') then IconIndex := 1
else if (FileExt = '.EXE')
or (FileExt = '.COM') then IconIndex := 2
else if (FileExt = '.HLP') then IconIndex := 23
else if (FileExt = '.INI')
or (FileExt = '.INF') then IconIndex := 63
else if (FileExt = '.TXT') then IconIndex := 64
else if (FileExt = '.BAT') then IconIndex := 65
else if (FileExt = '.DLL')
or (FileExt = '.SYS')
or (FileExt = '.VBX')
or (FileExt = '.OCX')
or (FileExt = '.VXD') then IconIndex := 66
else if (FileExt = '.FON') then IconIndex := 67
else if (FileExt = '.TTF') then IconIndex := 68
else if (FileExt = '.FOT') then IconIndex := 69
else IconIndex := 0;
// Attempt to get the icon.
if ExtractIconEx(pchar(FileName), IconIndex,
PLargeIcon^, PSmallIcon^, 1) <> 1 then
begin
// Failed to get the icon. Just "return" zeroes.
if PLargeIcon <> nil then PLargeIcon^ := 0;
if PSmallIcon <> nil then PSmallIcon^ := 0;
end;
end;
end;
Sample call
-----------
This example will change the icon of your form:
procedure TForm1.Button1Click(Sender: TObject);
var
SmallIcon: HICON;
begin
GetAssociatedIcon('file.doc', nil, @SmallIcon);
if SmallIcon <> 0 then
Icon.Handle := SmallIcon;
end;
