Delphi, C# .NET Tips & Tricks: 2007

Thursday, October 25, 2007

CRC Check / CRC Values

CRC values are calculated using an algorithm known as the Cyclic Redundancy Check, or "CRC" for short. Basically, this involves generating a 32-bit number (or "CRC value") based on the contents of a file. If the contents of a file change, its CRC value changes as well. This allows the CRC number to be used as a "checksum" in order to identify whether or not the file has changed. It also allows you to distinguish between different versions of a file by comparing its CRC value to the CRC values of the originals.

The basic idea of the CRC algorithm is to treat all the bits in a file as one big binary number, and then divide that number by a standard value. The remainder from the division is the CRC value.

You can think of this value as being like a fingerprint for each file. Unlike human fingerprints, however, it isn't impossible for two files to have the same CRC-32 value. UpdatesDownloader uses an industry-standard CRC-32 algorithm which generates CRC values that are 32 bits in length. This means that one in every 4,294,967,296 files could have the same CRC "fingerprint."

A file doesn't have to change much for its CRC value to be different. In fact, if even just one bit in a file changes, the CRC value for that file will change as well. If all you did was change one letter in a readme.txt file between version 1 and version 2, the CRC value for that readme.txt file would be completely different.

CRC values can be calculated for any type of file.

Although the chances of any two files having the same CRC value are incredibly small, the CRC value alone isn't enough to guarantee an accurate identification. If you need to be absolutely sure, check the CRC in addition to other information about the file, such as the size of the file in bytes and its location on the user's system.

Thursday, August 30, 2007

Sending an email using MAPI

There are lot of different methods to send mail using MAPI (Windows Simple Mail API)
If you do not want to rely on Outlook to send an email but you know that MAPI is installed, then you can also send mails with the following handy routine SendMailMAPI(). You need to add unit MAPI to your uses clause. Note that MAPI is not always installed with Windows.

unit uMAPIMail;

interface

uses MAPI;

function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
RecepientName, RecepientEMail: String) : Integer;

implementation

function SendMailMAPI(const Subject, Body, FileName, SenderName, SenderEMail,
RecepientName, RecepientEMail: String) : Integer;
var
message: TMapiMessage;
lpSender,
lpRecepient: TMapiRecipDesc;
FileAttach: TMapiFileDesc;
SM: TFNMapiSendMail;
MAPIModule: HModule;
begin
FillChar(message, SizeOf(message), 0);
with message do
begin
if (Subject<>'') then
begin
lpszSubject := PChar(Subject)
end;
if (Body<>'') then
begin
lpszNoteText := PChar(Body)
end;
if (SenderEMail<>'') then
begin
lpSender.ulRecipClass := MAPI_ORIG;
if (SenderName='') then
begin
lpSender.lpszName := PChar(SenderEMail)
end
else
begin
lpSender.lpszName := PChar(SenderName)
end;
lpSender.lpszAddress := PChar('SMTP:'+SenderEMail);
lpSender.ulReserved := 0;
lpSender.ulEIDSize := 0;
lpSender.lpEntryID := nil;
lpOriginator := @lpSender;
end;
if (RecepientEMail<>'') then
begin
lpRecepient.ulRecipClass := MAPI_TO;
if (RecepientName='') then
begin
lpRecepient.lpszName := PChar(RecepientEMail)
end
else
begin
lpRecepient.lpszName := PChar(RecepientName)
end;
lpRecepient.lpszAddress := PChar('SMTP:'+RecepientEMail);
lpRecepient.ulReserved := 0;
lpRecepient.ulEIDSize := 0;
lpRecepient.lpEntryID := nil;
nRecipCount := 1;
lpRecips := @lpRecepient;
end
else
begin
lpRecips := nil
end;
if (FileName='') then
begin
nFileCount := 0;
lpFiles := nil;
end
else
begin
FillChar(FileAttach, SizeOf(FileAttach), 0);
FileAttach.nPosition := Cardinal($FFFFFFFF);
FileAttach.lpszPathName := PChar(FileName);
nFileCount := 1;
lpFiles := @FileAttach;
end;
end;
MAPIModule := LoadLibrary(PChar(MAPIDLL));
if MAPIModule=0 then
begin
Result := -1
end else
begin
try
@SM := GetProcAddress(MAPIModule, 'MAPISendMail');
if @SM<>nil then
begin
Result := SM(0, Application.Handle, message, MAPI_DIALOG or MAPI_LOGON_UI,0);
end else
begin
Result := 1
end;

finally
FreeLibrary(MAPIModule);
end;
end
if Result<>0 then
begin
MessageDlg('Error sending mail ('+IntToStr(Result)+').', mtError, [mbOk], 0)
end;
end;

end.

Monday, August 20, 2007

Preventing second instance of the application

There are many ways, but we'll see couple of examples here...

a) Using "GlobalAddAtom" & "GlobalFindAtom" API calls

 
procedure TForm1.FormCreate(Sender: TObject);
begin
  {Searchs table to see if the program is already running} 
  if GlobalFindAtom('PROGRAM_RUNNING') = 0 then
   { If not found then add it }
   atom := GlobalAddAtom('PROGRAM_RUNNING')
  else begin
   { If program is already running the show message and halt }
   MessageDlg('You have the program running all ready!!', mtWarning, [mbOK], 0); 
   Halt;
  end;
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  {Removes the item from the table so it can be run again}
  GlobalDeleteAtom(atom);
end;

b) Using "CreateMutex" & "OpenMutex" you can control this from your *.dpr code itself. Here we will try to create the mutex (kernel) object on the OS when your application starts for the first time.
ex:
MutexHandle := CreateMutex(Nil, False, 'ANYTHING-WHICH-IS-UNIQUE-TO-UR-APP');
if MutexHandle returns zero(0) or some error, that means the mutex is already created and your application is running in the background. Here you can just quit the application or you throw some error message to the user, using the below code...


MutexHandle := OpenMutex(MUTEX_ALL_ACCESS, False, 'ANYTHING-WHICH-IS-UNIQUE-TO-UR-APP');

If MutexHandle retruns zero (0) or some error, then there is some problem with your kernel object just exit from there, otherwise you can show the error message like I have shown in the above example and quit from the application.
Finally, dont forget to free the MutexHandle. You will get more information when you search for "CreateMutex" "OpenMutex" in Google.com

c) Using "CreateFileMapping" / "MapViewOfFile" / "UnmapViewOfFile", its bit complex to understand, but if you are familiar with Windows API calls then it would probably help you.

Sunday, July 29, 2007

Sending Mail using Thread


unit uSMTPMailer;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, 
  Dialogs, IdMessage, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdMessageClient, IdSMTP, StdCtrls;

type
  TSendMail = class(TThread)
  private
    FPortNumber: Integer;
    FSubject: String;
    FPassword: String;
    FServerName: String;
    FFromAddress: String;
    FBodyMessage: TStrings;
    FRecipientsList: TStrings;
    procedure SetBodyMessage(const Value: TStrings);
    procedure SetFromAddress(const Value: String);
    procedure SetPasword(const Value: String);
    procedure SetPortNumber(const Value: Integer);
    procedure SetRecipientsList(const Value: TStrings);
    procedure SetServerName(const Value: String);
    procedure SetSubject(const Value: String);
  public
    constructor Create(ASuspended: Boolean);
    property PortNumber: Integer read FPortNumber write SetPortNumber;
    property ServerName: String read FServerName write SetServerName;
    property Password: String read FPassword write SetPasword;
    property FromAddress: String read FFromAddress write SetFromAddress;
    property Recipients: TStrings  read FRecipientsList write SetRecipientsList;
    property Subject: String read FSubject write SetSubject;
    property Body: TStrings read FBodyMessage write SetBodyMessage;
    procedure SendEMail;
  protected
    procedure Execute;  override;
  end;

  function SendSMTPMail(APort: Integer;
                        ASMTPServer, APassword, AFromAddress: String;
                        AToAddresses, ABodyText: TStrings): Boolean;

implementation

{ TSendMail }
constructor TSendMail.Create(ASuspended: Boolean);
begin
  inherited Create(ASuspended);
  FreeOnTerminate := True;
  FBodyMessage := TStringList.Create;
  FRecipientsList := TStringList.Create;
end;

procedure TSendMail.Execute;
var
  FIdSMTP: TIdSMTP;
  FIdMessage: TIdMessage;
begin
  FIdSMTP := TIdSMTP.Create(nil);
  FIdMessage := TIdMessage.Create(nil);
  try
    FIdSMTP.Host := FServerName;
    FIdSMTP.Port := FPortNumber;
    FIdSMTP.Password:= FPassword;
    FIdMessage.From.Address := FFromAddress;
    FIdmessage.Recipients.Assign(FRecipientsList);
    FIdMessage.Subject := FSubject;
    FIdMessage.Body.Assign(FBodyMessage);
    try
      FIdSMTP.Connect;
      FIdSMTP.Send(FIdMessage);
    except end;
  finally
    if FIdSMTP.Connected then FIdSMTP.Disconnect;
    FreeAndNil(FIdMessage);
    FreeAndNil(FIdSMTP);
  end;
end;

procedure TSendMail.SendEMail;
begin
  Resume;
end;

procedure TSendMail.SetBodyMessage(const Value: TStrings);
begin
  FBodyMessage.Assign(Value);
end;

procedure TSendMail.SetFromAddress(const Value: String);
begin
  FFromAddress := Value;
end;

procedure TSendMail.SetPasword(const Value: String);
begin
  FPassword := Value;
end;

procedure TSendMail.SetPortNumber(const Value: Integer);
begin
  FPortNumber := Value;
end;

procedure TSendMail.SetRecipientsList(const Value: TStrings);
begin
  FRecipientsList.Assign(Value);
end;

procedure TSendMail.SetServerName(const Value: String);
begin
  FServerName := Value;
end;

procedure TSendMail.SetSubject(const Value: String);
begin
  FSubject := Value;
end;

function SendSMTPMail(APort: Integer; ASMTPServer, APassword,
  AFromAddress: String; AToAddresses, ABodyText: TStrings): Boolean;
begin
  try
    with TSendMail.Create(True) do
    begin
      PortNumber := APort;
      ServerName := ASMTPServer;
      Password   := APassword;
      FromAddress := AFromAddress;
      Recipients.Assign(AToAddresses);
      Body.Assign(ABodyText);
      SendEMail;
      {no need to free, its a self destructive thread}
    end;
    Result := True;
  except
    Result := False;
  end;
end;

end.

Thursday, July 26, 2007

Display a shaded column like Windows Explorer in XP

The Windows Explorer in XP displays the sorted column in pale grey. We can bring up similar behaviour in Delphi TListView by handling all two OnCustomDraw, OnColumnClick events to display a list view with a specified column shaded in pale grey.


procedure TForm1.ListView1ColumnClick(Sender: TObject; Column: TListColumn);
begin
  FColumnToSort := Column.Index;
  ListView1.Invalidate;
end; 

procedure TForm1.ListView1CustomDraw(Sender: TCustomListView; const ARect: TRect; var DefaultDraw: Boolean);
var
  ColLeft: Integer;   
  ColBounds: TRect;
  I: Integer;      
begin
  ColLeft := ARect.Left;
  for I := 0 to Pred(FColumnToSort) do
    ColLeft := ColLeft + ListView_GetColumnWidth(ListView1.Handle, I);

  ColBounds := Rect(ColLeft, ARect.Top, ColLeft + ListView_GetColumnWidth(ListView1.Handle, FColumnToSort), ARect.Bottom);

  ListView1.Canvas.Brush.Color := clSilver;
  ListView1.Canvas.FillRect(ColBounds);
end;

Monday, June 25, 2007

Calculate Size of Folders, Sub folders and files


function DirSize(const ADirName : string; ARecurseDirs : boolean = true): integer;
const 
  FIND_OK = 0;
var 
  nResult : integer;

  procedure _RecursiveDir(const ADirName : string);
  var 
   sDirName : String;
   rDirInfo : TSearchRec;
   nFindResult : Integer;
  begin
    sDirName := IncludeTrailingPathDelimiter(ADirName);
    nFindResult := FindFirst(sDirName + '*.*',faAnyFile,rDirInfo);

    while nFindResult = FIND_OK do 
    begin
      // Ignore . and .. directories
      if (rDirInfo.Name[1] <> '.') then 
      begin
        if (rDirInfo.Attr and faDirectory = faDirectory) and ARecurseDirs then
           RecursiveDir(sDirName + rDirInfo.Name) // Keep Recursing
        else
          inc(nResult, rDirInfo.Size); // Accumulate Sizes
      end;

      nFindResult := FindNext(rDirInfo);
      if nFindResult <> FIND_OK then 
        FindClose(rDirInfo);
    end;
  end;

// DirSize Main
begin
  Screen.Cursor := crHourGlass;
  Application.ProcessMessages;
  nResult := 0;
  RecursiveDir(ADirName);
  Screen.Cursor := crDefault;

  Result := nResult;
end;

How to catch kernel-signals in Kylix?


program TestSignals; 

{$APPTYPE CONSOLE} 

uses Libc; 

var 
  bTerminate: Boolean; 

procedure SignalProc(SigNum: Integer); cdecl; 
begin 
  case SigNum of  
    SIGQUIT:  
      begin 
        WriteLn('signal SIGQUIT'); 
        bTerminate := true; 
      end; 
    SIGUSR1: WriteLn('signal SIGUSR1'); 
    else 
      WriteLn('not handled signal'); 
  end; 
  signal(SigNum, SignalProc);
end; 

begin 
  bTerminate := false; 

  signal(SIGQUIT, SignalProc);  
  signal(SIGUSR1, SignalProc);  
   
  repeat  
    sleep(1); 
  until bTerminate; 
end.

How do I determine if the user has Administrator privileges under Windows 2000/NT?


This is not a completely intuitive process, however, it can be done by combining a few different Windows API functions, as shown in the following code sample:

function IsAdmin: Boolean;
var
  hAccessToken       : tHandle;
  ptgGroups          : pTokenGroups;
  dwInfoBufferSize   : DWORD;
  psidAdministrators : PSID;
  int                : integer;   
  blnResult          : boolean;         

const
 SECURITY_NT_AUTHORITY: SID_IDENTIFIER_AUTHORITY = 
    (Value: (0,0,0,0,0,5)); // ntfs
 SECURITY_BUILTIN_DOMAIN_RID: DWORD = $00000020;
 DOMAIN_ALIAS_RID_ADMINS: DWORD = $00000220;
 DOMAIN_ALIAS_RID_USERS : DWORD = $00000221;
 DOMAIN_ALIAS_RID_GUESTS: DWORD = $00000222;
 DOMAIN_ALIAS_RID_POWER_: DWORD = $00000223;

begin
  Result := False;
  blnResult := OpenThreadToken( GetCurrentThread, TOKEN_QUERY, 
                                True, hAccessToken );
  if ( not blnResult ) then
  begin
    if GetLastError = ERROR_NO_TOKEN then
    blnResult := OpenProcessToken( GetCurrentProcess, 
           TOKEN_QUERY, hAccessToken );
  end;

  if ( blnResult ) then
  try

    GetMem(ptgGroups, 1024);
    blnResult := GetTokenInformation( hAccessToken, TokenGroups,
                                      ptgGroups, 1024, 
                                      dwInfoBufferSize );
    CloseHandle( hAccessToken );

    if ( blnResult ) then
    begin

      AllocateAndInitializeSid( SECURITY_NT_AUTHORITY, 2,
                                SECURITY_BUILTIN_DOMAIN_RID, 
                                DOMAIN_ALIAS_RID_ADMINS,
           0, 0, 0, 0, 0, 0, 
           psidAdministrators );
      {$R-} 
      for int := 0 to ptgGroups.GroupCount - 1 do

        if EqualSid( psidAdministrators, 
                     ptgGroups.Groups[ int ].Sid ) then 
        begin
          Result := True;
          Break;
        end;
      {$R+}

      FreeSid( psidAdministrators ); 
    end;

  finally
    FreeMem( ptgGroups ); 
  end;
end;

User Management through Win32 call

Check out the JCL (JediVCL) it has a routine from lanmanager(JcLanMan.pas)


function CreateAccount(const Server, Username, Fullname, Password,
Description,
  Homedir, Script: string; const PasswordNeverExpires: Boolean):
Boolean;
var
  wServer, wUsername, wFullname,
  wPassword, wDescription, wHomedir, wScript: WideString;
  Details: USER_INFO_2;
  Err: NET_API_STATUS;
  ParmErr: DWORD;
begin
  wServer := Server;
  wUsername := Username;
  wFullname := Fullname;
  wPassword := Password;
  wDescription := Description;
  wScript := Script;
  wHomedir := Homedir;

  FillChar (Details, SizeOf(Details), 0);
  with Details do
  begin
    usri2_name := PWideChar(wUsername);
    usri2_full_name := PWideChar(wFullname);
    usri2_password := PWideChar(wPassword);
    usri2_comment := PWideChar(wDescription);
    usri2_priv := USER_PRIV_USER;
    usri2_flags := UF_SCRIPT;
    if PassWordNeverExpires then
      usri2_flags := usri2_flags or UF_DONT_EXPIRE_PASSWD;
    usri2_script_path := PWideChar(wScript);
    usri2_home_dir := PWideChar(wHomedir);
    usri2_acct_expires := TIMEQ_FOREVER;
  end;

  Err := NetUserAdd(PWideChar(wServer), 2, @Details, @ParmErr);
  Result := (Err = NERR_SUCCESS);
end;

C:\>cacls /?
Displays or modifies access control lists (ACLs) of files

CACLS filename [/T] [/E] [/C] [/G user:perm] [/R user [...]]
[/P user:perm [...]] [/D user [...]]
filename Displays ACLs.
/T Changes ACLs of specified files in
the current directory and all subdirectories.
/E Edit ACL instead of replacing it.
/C Continue on access denied errors.
/G user:perm Grant specified user access rights.
Perm can be: R Read
C Change (write)
F Full control
/R user Revoke specified user's access rights (only valid with /E).
/P user:perm Replace specified user's access rights.
Perm can be: N None
R Read
C Change (write)
F Full control
/D user Deny specified user access.
Wildcards can be used to specify more that one file in a command.
You can specify more than one user in a command.

Add checkboxes to a TShellTreeView


unit Unit1;

interface

uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ShellCtrls;

type
TCheckBoxShellTreeView = class(ShellCtrls.TShellTreeView)
public
procedure CreateParams(var Params: TCreateParams); override;
end;

TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
ShellTreeView: TCheckBoxShellTreeView;
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

const
TVS_CHECKBOXES = $00000100;

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);
begin
ShellTreeView := TCheckBoxShellTreeView.Create(Self);
with ShellTreeView do
begin
Name := 'ShellTreeView';
Parent := Self;
Root := 'rfDesktop';
UseShellImages := True;
Align := alClient;
AutoRefresh := False;
BorderStyle := bsNone;
Indent := 19;
ParentColor := False;
RightClickSelect := True;
ShowRoot := False;
TabOrder := 0;
end;
end;

procedure TCheckBoxShellTreeView.CreateParams(var Params: TCreateParams);
begin
inherited;
Params.Style := Params.Style or TVS_CHECKBOXES;
end;

end.

Adding TCheckbox to TCombobox

You need to do the following:

Set ComboBox.Style:=csOwnerDrawFixed

//..... your form class
private
Selected: array of Boolean;
//.....


procedure TForm1.ComboBox1DrawItem(Control: TWinControl;
     Index: Integer; Rect: TRect; State: TOwnerDrawState);
begin
  SetLength(Selected, TComboBox(Control).Items.Count);
  with TComboBox(Control).Canvas do
  begin
    FillRect(rect);

    Rect.Left := Rect.Left + 1;
    Rect.Right := Rect.Left + 13;
    Rect.Bottom := Rect.Bottom;
    Rect.Top := Rect.Top;

    if not (odSelected in State) and (Selected[Index]) then
      DrawFrameControl(Handle, Rect, DFC_BUTTON,
        DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_FLAT)
    else if (odFocused in State) and (Selected[Index]) then
      DrawFrameControl(Handle, Rect, DFC_BUTTON,
        DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_FLAT)
    else if (Selected[Index]) then
      DrawFrameControl(Handle, Rect, DFC_BUTTON,
        DFCS_BUTTONCHECK or DFCS_CHECKED or DFCS_FLAT)
    else if not (Selected[Index]) then
      DrawFrameControl(Handle, Rect, DFC_BUTTON, DFCS_BUTTONCHECK or DFCS_FLAT);

    TextOut(Rect.Left + 15, Rect.Top, TComboBox(Control).Items[Index]);
  end;
end;

procedure TForm1.ComboBox1Select(Sender: TObject);
var
  i: Integer;
  Sel: string;
begin
  Sel := EmptyStr;
  Selected[TComboBox(Sender).ItemIndex] := not Selected[TComboBox(Sender).ItemIndex];
  for i := 0 to TComboBox(Sender).Items.Count - 1 do
    if Selected[i] then
      Sel := Sel + TComboBox(Sender).Items[i] + ' ';
  ShowMessage(Sel);  //Just for test...
end;

Adding data to a compiled Executable file

You can't proof whether additional data is attached or not.
To reach this, you would have to create a checksumm of the
MemoryStream and attach it.

try this out:


function AttachToFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean; 
var 
  aStream: TFileStream; 
  iSize: Integer; 
begin 
  Result := False; 
  if not FileExists(AFileName) then 
    Exit; 
  try 
    aStream := TFileStream.Create(AFileName, fmOpenWrite or fmShareDenyWrite); 
    MemoryStream.Seek(0, soFromBeginning); 
    // seek to end of File 
    // ans Ende der Datei Seeken 
    aStream.Seek(0, soFromEnd); 
    // copy data from MemoryStream 
    aStream.CopyFrom(MemoryStream, 0); 
    // save Stream-Size 
    iSize := MemoryStream.Size + SizeOf(Integer); 
    aStream.Write(iSize, SizeOf(iSize)); 
  finally 
    aStream.Free; 
  end; 
  Result := True; 
end; 

function LoadFromFile(const AFileName: string; MemoryStream: TMemoryStream): Boolean; 
var 
  aStream: TFileStream; 
  iSize: Integer; 
begin 
  Result := False; 
  if not FileExists(AFileName) then 
    Exit; 

  try 
    aStream := TFileStream.Create(AFileName, fmOpenRead or fmShareDenyWrite); 
    // seek to position where Stream-Size is saved 
    aStream.Seek(-SizeOf(Integer), soFromEnd); 
    aStream.Read(iSize, SizeOf(iSize)); 
    if iSize > aStream.Size then 
    begin 
      aStream.Free; 
      Exit; 
    end; 
    // seek to position where data is saved 
    aStream.Seek(-iSize, soFromEnd); 
    MemoryStream.SetSize(iSize - SizeOf(Integer)); 
    MemoryStream.CopyFrom(aStream, iSize - SizeOf(iSize)); 
    MemoryStream.Seek(0, soFromBeginning); 
  finally 
    aStream.Free; 
  end; 
  Result := True; 
end; 

procedure TForm1.SaveClick(Sender: TObject); 
var 
  aStream: TMemoryStream; 
begin 
  aStream := TMemoryStream.Create; 
  Memo1.Lines.SaveToStream(aStream); 
  AttachToFile('Test.exe', aStream); 
  aStream.Free; 
end; 

procedure TForm1.LoadClick(Sender: TObject); 
var 
  aStream: TMemoryStream; 
begin 
  aStream := TMemoryStream.Create; 
  LoadFromFile('Test.exe', aStream); 
  Memo1.Lines.LoadFromStream(aStream); 
  aStream.Free; 
end;

How can i call 16-bit dll function from win32?


const 
  Gfsr_SystemResources = 0; 
  Gfsr_GdiResources = 1; 
  Gfsr_UserResources = 2; 
var 
  hInst16: THandle; 
  GFSR: Pointer; 

{ Undocumented Kernel32 calls. } 
function LoadLibrary16(LibraryName: PChar): THandle; stdcall; external kernel32 index 35; 
procedure FreeLibrary16(HInstance: THandle); stdcall; external kernel32 index 36; 
function GetProcAddress16(Hinstance: THandle; ProcName: PChar): Pointer; stdcall; external kernel32 index 37; 
procedure QT_Thunk; cdecl; external kernel32 name 'QT_Thunk'; 

{ QT_Thunk needs a stack frame. } 
{$StackFrames On} 
{ Thunking call to 16-bit USER.EXE. The ThunkTrash argument allocates space on the stack for QT_Thunk. } 

function NewGetFreeSystemResources(SysResource: Word): Word; 
var 
  ThunkTrash: array[0..$20] of Word; 
begin 
  { Prevent the optimizer from getting rid of ThunkTrash. } 
  ThunkTrash[0] := hInst16; 
  hInst16 := LoadLibrary16('user.exe'); 
  if hInst16 < 32 then 
    raise Exception.Create('Can''t load USER.EXE!'); 
  { Decrement the usage count. This doesn't really free the library, since USER.EXE is always loaded. } 
  FreeLibrary16(hInst16); 
  { Get the function pointer for the 16-bit function in USER.EXE. } 
  GFSR := GetProcAddress16(hInst16, 'GetFreeSystemResources'); 
  if GFSR = nil then 
    raise Exception.Create('Can''t get address of GetFreeSystemResources!'); 
  { Thunk down to USER.EXE. } 
  asm 
    push SysResource  { push arguments } 
    mov edx, GFSR     { load 16-bit procedure pointer } 
    call QT_Thunk     { call thunk } 
    mov Result, ax    { save the result } 
  end; 
end;