Vb, Delphi, .net, framework, C++, Java, Pascal,Visual Studio, Asm, Ruby, C#, j#, Cs, Html, Php, Perl, Asp, xHtml Get Free Souce Code Here...



How to use the keyboard as input for games - Delphi

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 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

This is helpful if you do not want to have a bitmap file in the directory of the program you distribute.

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 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

ExtractAssociatedIcon
---------------------

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;