Windows Functions V3.07

$ Include ../cdefines.inc}

Unit Cwindows;

{}

{Windows Functions V3.07}

{}

{THIS UNIT IS COPYRIGHT? 2000-2004 by David J Butler}

{}

{THIS UNIT IS Part of Delphi Fundamentals.

{ITS Original File Name Is CWindows.PAS}

{The Latest Version IS Available from The Fundamentals Home Page}

{Http://fundementals.sourceforge.net/}

{}

{I invite you to use this unit, free of charge.

{I invite you to distibute this unit, but it must be for free.

{I also invite you to controle to its development,}

{But do not distribute a modified copy of this file.

{}

{A forum is available on sourceforge for general discussion}

{Http://sourceforge.net/forum/forum.php?forum_id=2117}

{}

{Description:}

{MS Windows Specific Functions.

{} {Revision history:}

{2000/10/01 1.01 Initial Version CREATED from Cutils.

{2001/12/12 2.02 Added awindowhandle.

{2002/03/15 2.03 Added getwinostype.

{2002/06/26 3.04 Refactored for Fundamentals 3.}

{2002/09/22 3.05 moved registry functions to unit cregistry.

{2003/01/04 3.06 Added Reboot function.

{2003/10/01 3.07 Updated getWindowsVersion function.

{}

Interface

Uses

{DELPHI}

Windows,

Messages,

SYSUTILS,

Classes,

{Fundamentals}

CUTILS;

{}

{Windows Version}

{}

Type

TWINDOWSVERSION =

// 16-bit windows

Win16_31,

// 32-Bit Windows Win32_95, Win32_95R2, Win32_98, Win32_98se, Win32_me, Win32_Future,

// Windows NT 3

Winnt_31, Winnt_35, Winnt_351,

// Windows NT 4

Winnt_40,

// Windows NT 5

Winnt5_2000, Winnt5_XP, Winnt5_2003, Winnt5_Future,

// Windows NT 6

Winnt_future,

// Windows Post-NT

WIN_FUTURE);

TwindowsVersions = SET

Of TwindowsVersion;

Function GetWindowsVersion: TwindowsVersion;

Function iswinplatform95:

Boolean;

Function iswinplatformNT:

Boolean;

Function GetWindowsProductID:

String;

{} {Windows paths}

{}

Function GetWindowsTemportPath:

String;

Function GetWindowsPath:

String;

Function GetWindowSystempath:

String;

Function GetProgramFileSpath:

String;

Function GetcommonFileSpath:

String;

Function GetApplicationPath:

String;

{}

{Identification}

{}

Function GetUsername:

String;

Function GetLocalComputename:

String;

Function GetLocalHostname:

String;

{}

{Application Version Info}

{}

Type

TVersionInfo = (Vifileversion, VifiLledescription, Vilegalcopyright,

Vicomments, VicompanyName, ViInternalName,

VilegalTradeMarks, ViORIGINALFILENAME, VIPRODUCTNAME,

ViproductVersion;

Function GetAppVersionInfo

Const VersionInfo: TVERSIONFO:

String;

{}

{Windows Processes}

{}

Function Winexecute

Const Exename, Params:

String;

Const showwin: Word = sw_shownormal;

Const Wait:

Boolean =

True):

Boolean; {}

{EXIT Windows}

{}

{$ IFNDEF FREEPASCAL}

Type

TexitWindowsType = (ExitLogf, EXITPOWEROFF, EXITREBOOT, EXITSHUTDOWN);

Function EXITWINDOWS

Const exittype: texitwindowstype;

Const Force:

Boolean =

FALSE):

Boolean;

Function logoff

Const Force:

Boolean =

FALSE):

Boolean;

Function Poweroff

Const Force:

Boolean =

FALSE):

Boolean;

Function Reboot

Const Force:

Boolean =

FALSE):

Boolean;

Function shutdown

Const Force:

Boolean =

FALSE):

Boolean;

{$ ENDIF}

{}

{Windows Fibers}

{Thase Functions Are Redeclared Because Delphi 7'S Windows.Pas Declare}

{.}

{}

{$ IFDEF FREEPASCAL}

Type

Tfnfnfiberstartroutine = TfarProc;

{$ ENDIF}

Function ConvertThreadTofiber: Pointer; stdcall;

Function CreateFiber (DWSTACKSIZE: DWORD; LPSTARTDRESS: TFNFIBERSTARTROUTINE;

LPPARETER: POINTER: Pointer; stdcall;

{}

{Miscelleneous Windows API}

{}

Function Getenvironmentstrings: StringArray;

Function ContentTypeFromExtent (const extention)

String):

String;

Function FileClassFromExtens (

Const Extention:

String):

String;

Function GetFileClass

Const filename:

String):

String;

Function getFileAssociation

Const filename:

String):

String;

Function isapplicationAutorun

Const Name:

String):

Boolean;

Procedure setApplicationAutorun

Const Name:

String;

Const Autorun:

Boolean;

{$ IFNDEF FREEPASCAL}

Function GetWinportNames: StringArray;

{$ ENDIF}

Function getKeyPressed (

Const vkeycode:

Integer:

Boolean;

Function GethardDisk SerialNumber

Const Driveletter: Char):

String;

{}

{Wininet API}

{}

Type

TIEPROXY = (IEPHTTP, IEPHTTPS, IEPFTP, IEPGOPHER, IEPSOCKS);

{$ IFNDEF FREEPASCAL}

Function GetieProxy (

Const Protocol: TIEPROXY:

String;

{$ ENDIF}

{}

{Window Handle}

{Base class for allocation of a new window handle what can process its oown}

{Messages.

{}

Type

TwindowHandleMessageEvent =

FUNCTION

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer;

Var Handled:

Boolean:

Integer

Of Object;

Twindowhandle =

Class;

Twindowhandleevent =

PROCEDURE

Const sender: twindowhandle)

Of Object;

TwindowHandleerRorevent =

Procedure (Const Sender: TwinDowHandle;

Const E: Exception)

Of Object;

Twindowhandle =

Class (tcomponent)

protected

Fwindowhandle: hwnd;

Fterminated:

Boolean;

FONMESSAGE: TwindowHandleMessageEvent;

FONEXCEPTION: TWINDOWHANDLEERREVENT;

FONBEFOREMESSAGE: TWINDOWHANDEVENT;

FonafterMessage: Twindowhandleevent;

Procedure raiseerror

Const msg:

String);

Function AllocateWindowHandle: hwnd;

Virtual;

Function MessageProc

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Integer;

Function Handlewm

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Integer;

Virtual;

public

DESTRUCTOR DESTROY;

OVERRIDE;

Procedure destroywindowhandle;

Virtual;

Property WindowHandle: hwnd read fwindowhandle;

Function getWindowhandle: hwnd;

Function ProcessMessage:

Boolean;

Procedure processmessages;

Function HandleMessage:

Boolean;

Procedure messageloop;

Property OnMessage: TwindowHandleMessageEvent Read Fonmessage Write Fonmessage;

Property Onexception: TwindowHandleerRorevent Read FONEXCEPTION WRITE FONEXCEPTION;

Property OnbeforeMessage: TwindowHandleevent Read FonbeforeMessage Write FonbeforeMessage

Property OnAfterMessage: TwindowHandleevent Read FonafterMessage Write FonafterMessage;

Property Terminated:

Boolean read fterminated;

Procedure terminate;

Virtual;

END;

Ewindowhandle =

Class (Exception);

{Tfndwindowhandle}

{Published Window Handle Component.

TfndWindowHandle =

Class (TwindowHandle)

Published

Property OnMessage;

Property OnException;

END;

{} {TTIMERHANDLE}

{}

Type

TTIMERHANDLE =

Class;

TTIMEREVENT =

PROCEDURE

Const sender: TTIMERHANDLE)

Of Object;

TTIMERHANDLE =

Class (TwindowHandle)

protected

FTIMERINTERVAL:

Integer;

FTIMERACTIVE:

Boolean;

FONTIMER: TTIMEREVENT;

Function Handlewm

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Integer;

OVERRIDE;

Function Dosettimer:

Boolean;

Procedure Triggertimer;

Virtual;

Procedure setTimerActive

Const TimerActive:

Boolean;

Virtual;

Procedure loaded;

OVERRIDE;

public

Constructor Create (Aowner: Tcomponent);

OVERRIDE;

Procedure destroywindowhandle;

OVERRIDE;

Property TimerInterVal:

Integer Read ftimerinterval Write fTimerInterVal Default

1000;

Property TimerActive:

Boolean Read FTIMERACTIVE WRITE SETTIMERACTIVE DEFAULT

False;

Property ONTIMER: TTIMEREVENT Read Fontimer Write Fontimer;

END;

{Tfndtimerhandle}

{Published Timer Handle Component.

TfndtimerHandle =

Class (TTIMERHANDLE)

Published

Property OnMessage;

Property OnException;

Property TimerInterVal;

Property TimerActive;

Property ONTIMER;

END;

{$ IFNDEF DELPHI6_UP}

{}

{Raiselastoserror}

{}

Procedure raiselastoserror;

{$ ENDIF}

ImplementationUses

{DELPHI}

Winsock,

{$ IFNDEF FREEPASCAL}

Winspool,

Wininet,

{$ ENDIF}

{Fundamentals}

CStrings,

Cregistry;

{$ IFNDEF DELPHI6_UP}

{}

{Raiselastoserror}

{}

Procedure raiselastoserror;

Begin

{$ IFDEF FREEPASCAL}

Raise Exception.create

'OS Error');

{$ Else}

Raiselastwin32error;

{$ ENDIF}

END;

{$ ENDIF}

{}

{Windows Version Info}

{}

{$ IFDEF FREEPASCAL}

VAR

Win32Platform:

Integer;

Win32majorversion:

Integer;

Win32minorVersion:

Integer;

Win32csdversion:

String;

Procedure initplatform;

Var OsversionInfo: TOSVERSIONFO;

Begin

OsversionInfo.dwosveionsInfosize: = Sizeof (OsversionInfo);

IF getversionEx (OsversionInfo)

THEN

With osversioninfo

DO

Begin

Win32Platform: = dwplatformID;

Win32majorversion: = dwmajorversion;

Win32minorversion: = dwminorversion;

Win32csdversion: = szcsdversion;

END;

END;

{$ ENDIF}

Function GetWindowsVersion: TwindowsVersion;

Begin

Case Win32Platform

Of

VER_PLATFORM_WIN32S:

Result: = Win16_31;

VER_PLATFORM_WIN32_WINDOWS:

IF Win32majorversion <=

4

THEN

Case Win32minorVersion

Of

0 ..

9 :

IF TRIM (Win32csdversion, CSWHITESPACE) =

'B'

THEN

Result: = Win32_95R2

Else

Result: = Win32_95;

10 ..

89:

IF Trim (win32csdversion, cswhitespace) = 'a'

THEN

Result: = WIN32_98SE

Else

Result: = Win32_98;

90 ..

99: Result: = WIN32_ME;

Else

Result: = WIN32_FUTURE;

end

Else

Result: = WIN32_FUTURE;

VER_PLATFORM_WIN32_NT:

Case Win32majorVersion

Of

3:

Case Win32minorVersion

Of

1,

10 ..

19: Result: = WINNT_31;

5,

50: Result: = WINNT_35;

51 ..

99: Result: = WINNT_351;

Else

Result: = WinNT_31;

END;

4: Result: = WinNT_40;

5:

Case Win32minorVersion

Of

0: Result: = WinNT5_2000;

1: Result: = WinNT5_XP;

2: Result: = WINNT5_2003;

Else

Result: = WINNT5_FUTURE;

END;

Else

Result: = WINNT_FUTURE;

END;

Else

Result: = WIN_FUTURE;

END;

END;

Function iswinplatform95:

Boolean;

Begin

Result: = WIN32PLATFORM = VER_PLATFORM_WIN32_WINDOWS;

END;

Function iswinplatformNT:

Boolean;

Begin

Result: = Win32PLATFORM = VER_PLATFORM_WIN32_NT;

END;

Function GetWindowsProductID:

String;

Begin

Result: = getRegistryString (HKEY_LOCAL_MACHINE,

'Software / Microsoft / Windows / CurrentVersion',

'ProductID');

END;

{}

{Windows paths}

{}

Function GetWindowsTemportPath:

String;

Const maxtemppathlen = max_path

1;

VAR i: longword;

Begin

SETLENGTH (Result, Maxtemppathlen);

I: = GetTemppath (Maxtemppathlen, Pchar (Result));

IF i>

0

THEN

SETLENGTH (Result, i)

Else

Result: =

'';

END;

Function GetWindowsPath:

String;

Const maxwinpathlen = max_path 1;

VAR i: longword;

Begin

SETLENGTH (Result, MaxWinPathlen);

I: = getWindowsDirectory (Pchar (Result), MaxwinPathlen;

IF i>

0

THEN

SETLENGTH (Result, i)

Else

Result: =

'';

END;

Function GetWindowSystempath:

String;

Const maxwinsyspathlen = max_path

1;

VAR i: longword;

Begin

SETLENGTH (Result, Maxwinsyspathlen);

I: = GetSystemDirectory (pchar (result), maxwinsyspathlen;

IF i>

0

THEN

SETLENGTH (Result, i)

Else

Result: =

'';

END;

Const

CurrentVersionRegistryKey =

'Software / Microsoft / Windows / CurrentVersion';

Function GetProgramFileSpath:

String;

Begin

Result: = getRegistryString (HKEY_LOCAL_MACHINE, CURRENTVERSIONREGISTRYKEY,

'Programfilesdir';

END;

Function GetcommonFileSpath:

String;

Begin

Result: = getRegistryString (HKEY_LOCAL_MACHINE, CURRENTVERSIONREGISTRYKEY,

'CommonFilesDir');

END;

Function GetApplicationPath:

String;

Begin

Result: = ExtractFilePath (Paramstr

0)));

StrensureSuffix (Result,

'/');

END;

{}

{Identification}

{}

Function GetUsername:

String;

Const max_username_length =

256;

Var L: longword;

Begin

L: = MAX_USERNAME_LENGTH

2;

SETLENGTH (RESULT, L);

IF Windows.getuserName (Pchar (Result), L)

And (l>

0)

THEN

SETLENGTH (Result, Strlen (Pchar (Result))

Else

Result: =

'';

END;

Function GetLocalComputename:

String;

Var L: longword;

Begin

L: = max_computername_LENGTH 2;

SETLENGTH (RESULT, L);

IF Windows.getComputername (Pchar (Result), L)

And (l>

0)

THEN

SETLENGTH (Result, Strlen (Pchar (Result))

Else

Result: =

'';

END;

Function GetLocalHostname:

String;

Const max_host_length = max_path;

Var Wsadata: TWSADATA;

L: longword;

Begin

IF WSAStartup

$ 0101, WSADATA) =

0

THEN

Try

L: = max_host_length

2;

SetLENGTHANDZERO (RESULT, L);

IF gethostname (pchar (result), L) =

0

THEN

SETLENGTH (Result, Strlen (Pchar (Result))

Else

Result: =

'';

Finally

WSACLEANUP;

END;

END;

{}

{Application Version Info}

{}

VAR

VersionInfobuf: Pointer = NIL;

Vertransser:

String;

// Returns True IF Versionfo is Available

Function loadappversionInfo:

Boolean;

Type TTRANSBUFFER =

Array [

1..

4]

Of smallint;

PTRANSBUFFER = ^ TTRANSBUFFER;

VAR Infosize:

Integer;

Size, H: longword;

Exename:

String;

PTRANSBUFFER;

Begin

Result: = Assigned (VersionInfobuf);

IF Result

THEN

EXIT;

Exename: = Paramstr

0);

Infesize: = getFileVersionFosize (Pchar (Exename), H);

IF infosize =

0

THEN

EXIT;

GetMem (VersionInfobuf, Infosize);

IF

Not getFileVersionInfo (Pchar (Exename), H, Infosize, VersionInfobuf

THEN

Begin

FreeMem (VersionInfobuf);

VersionInfobuf: = nil;

EXIT;

END;

VERQUERYVALUE (VersionInfobuf, Pchar (

'/ Varfileinfo / translation'),

Pointer (TRANS), SIZE

Vertransser: = INTTOHEX (Trans ^ [

1],

4) INTTOHEX (Trans ^ [2],

4);

Result: =

True;

END;

Const

VersionFostr:

Array [TVersionInfo]

Of

String =

(

'Fileversion',

'Filedescription',

'LegalcopyRight',

'Comments',

'CompanyName',

'InternalName',

'Legaltrademarks',

'OriginalFileName',

'ProductName',

'ProductVersion';

Function GetAppVersionInfo

Const VersionInfo: TVERSIONFO:

String;

Var S:

String;

Size: longword;

Value: pchar;

Begin

Result: =

'';

IF

Not loadingAppVersionInfo

THEN

EXIT;

S: =

'StringFileInfo /' VertransStr

'/' VersionFostr [VersionInfo];

IF VERQUERYVALUE (VersionInfobuf, Pchar (s), Pointer (Value), Size

THEN

Result: = Value;

END;

{}

{Windows Processes}

{}

Function Winexecute

Const Exename, Params:

String;

Const showwin: Word;

Const Wait:

Boolean:

Boolean;

Var Startupinfo: TStartupinfo;

PROCESSINFO: TPROCESSINFORMATION;

CMD:

String;

Begin

IF params =

'' '

THEN

Cmd: = exename

Else

CMD: = Exename

'' Params;

Fillchar (StartupInfo, Sizeof (Startupinfo),

# 0);

Startupinfo.cb: = sizeof (startupinfo);

Startupinfo.dwflags: = startf_useshowwindow;

// startf_usestdhandles

Startupinfo.WshowWindow: = showwin;

Result: = CREATEPROCESS

NIL, PCHAR (CMD), NIL, NIL,

False,

Create_new_console

OR NORMAL_PRIORITY_CLASS, NIL,

Pchar (ExtractFilePath (Exename)), Startupinfo, ProcessInfo; if Wait

THEN

WaitforsingleObject (ProcessInfo.hprocess, Infinite);

END;

{}

{EXIT Windows}

{}

{$ IFNDEF FREEPASCAL}

Function EXITWINDOWS

Const exittype: texitwindowstype;

Const Force:

Boolean:

Boolean;

Const se_shutdown_name =

'SESHUTDOWNPRIVILEGE';

EXITTYPEFLAGS:

Array [texitwindowstype]

Of cardinal =

(EWX_LOGOFF, EWX_Poweroff, EWX_REBOOT, EWX_SHUTDOWN);

Var HToken: cardinal

TKP: TTOKENPRIVILEGES;

RetVal: cardinal

Uflags: cardinal;

Begin

IF IswinPlatFormnt

THEN

If OpenProcessToken (GetCurrentProcess (), Token_Adjust_Privileges

Or Token_Query, HTOKEN

THEN

Begin

Lookuppprivilerage (Nil, SE_SHUTDOWN_NAME, TKP.PRIVILEGES [

0] .luid);

Tkp.privilegect: =

1;

Tkp.privileges [

0] .attributes: = SE_PRIVILEGE_ENABED;

AdjustTokenPrivileges (HTOKEN,

False, TKP,

0, TKP, RETVAL);

END;

Uflags: = exittypeflags [exittype];

IF force

THEN

Uflags: = uflags

OR EWX_FORCE;

Result: = Windows.exitWindowsex (uflags,

0);

END;

Function logoff

Const Force:

Boolean =

FALSE):

Boolean;

Begin

Result: = exitwindows (exitLogoff, force);

END;

Function Poweroff

Const Force:

Boolean =

FALSE):

Boolean;

Begin

Result: = exitwindows (exitpoweroff, force);

END;

Function Reboot

Const Force:

Boolean:

Boolean;

Begin

Result: = exitwindows (exitReboot, force);

END;

Function shutdown

Const Force:

Boolean =

FALSE):

Boolean;

Begin

Result: = EXIXINDOWS (EXITSHUTDOWN, FORCE);

{$ ENDIF}

{}

{Windows Fibers}

{}

Function ConvertThreadTofiber; External Kernel32 Name

'ConvertThreadTofiber';

Function CreateFiber (DWSTACKSIZE: DWORD; LPSTARTDRESS: TFNFIBERSTARTROUTINE;

LPParameter: Pointer: Pointer; External Kernel32 Name

'CreateFiber';

{}

{Miscelleneous Windows API}

{}

Function Getenvironmentstrings: StringArray;

VAR P, Q: PCHAR;

I:

Integer;

S:

String;

Begin

P: = pchar (windows.GetenvironmentStrings);

Try

IF P ^ <>

# 0

THEN

Repeat

Q: = P;

I: =

0;

While Q ^ <>

# 0

DO

Begin

INC;

INC (I);

END;

SETLENGTH (S, I);

IF i>

0

THEN

Move (P ^, Pointer (s) ^, i);

Append (Result, S);

P: = Q;

INC (P);

Until P ^ =

# 0;

Finally

FreeENVIRONMENTSTRINGS (P);

END;

END;

Function ContentTyPefromextens

Const Extention:

String):

String;

Begin

Result: = getRegistryString (HKEY_CLASS_ROOT, EXTENTION,

'Content Type');

END;

Function FileClassFromExtens (

Const Extention:

String):

String;

Begin

Result: = getRegistryString (HKEY_CLASS_ROOT, EXTENTION,

');

END;

Function GetFileClass

Const filename:

String):

String;

Begin

Result: = FileClassFromExtens (extractfileext (filename);

END;

Function GetFileAssociation (const filename:

String):

String;

Var S:

String;

Begin

S: = FileClassFromExtent (ExtractFileExt (filename);

IF s =

'' '

THEN

Result: =

'' '

Else

Result: = getRegistryString (HKEY_CLASS_ROOT, S

'/ Shell / open / commist',

');

END;

Const

AutorunRegistryKey =

'Software / Microsoft / Windows / CurrentVersion / Run';

Function isapplicationAutorun

Const Name:

String):

Boolean;

Var S:

String;

Begin

S: = paramstr

0);

Result: = (s>

')

And (name <>

')

and

Strequalnocase (GetRegistryString (HKEY_LOCAL_MACHINE, AutorunregistryKey, Name), S);

END;

Procedure setApplicationAutorun

Const Name:

String;

Const Autorun:

Boolean;

Begin

if Name =

'' '

THEN

EXIT;

IF autorun

THEN

SetRegistryString (HKEY_LOCAL_MACHINE, AutorunregistryKey, Name, Paramstr

0))

Else

DeleteRegistryValue (HKEY_LOCAL_MACHINE, AutorunregistryKey, Name);

END;

{$ IFNDEF FREEPASCAL}

Function GetWinportNames: StringArray;

Var bytesneeded, N, i: longword;

BUF: POINTER;

Infoptr: PportInfo1;

Tempstr:

String;

Begin

Result: = NIL;

IF enumports (NIL,

1, NIL,

0, bytesneeded, n)

THEN

EXIT;

IF getLastError <> error_insuffect_buffer

THEN

Raiselastoserror;

GetMem (buf, bytesneed);

Try

IF

NOT Enumports (NIL,

1, BUF, BYTESNEED, BYTESNEED, N)

THEN

Raiselastoserror;

For i: =

0

TO N -

1

DO

Begin

Infoptr: = PportInfo1 (longword i * sizeof (tportinfo1));

Tempstr: = infoptr ^ .pname;

Append (Result, Tempstr);

END;

Finally

FreeMem (buf);

END;

END;

{$ ENDIF}

Function getKeyPressed (

Const vkeycode:

Integer:

Boolean;

Begin

Result: = getKeyState (vkeycode) and

$ 80 <>

0;

END;

{}

{Wininet API}

{}

Const

IEPROTOPREFIX:

Array [TIEPROXY]

Of

String =

(

'http =',

'https =',

'ftp =',

'gopher =',

'SOCKS =');

{$ IFNDEF FREEPASCAL}

Function GetieProxy (

Const Protocol: TIEPROXY:

String;

Var ProxyInfo: PinternetProxyinfo;

Len: longword;

PROXIES: STRINGARRAY;

I:

Integer;

Begin

PROXIES: = NIL;

Result: =

'';

Len: =

4096;

GetMem (ProxyInfo, Len);

Try

IF InternetQueryOption (nil, internet_option_proxy, proxyInfo, len)

THEN

IF proxyInfo ^ .dwaccesstype = Internet_Open_Type_Proxy

THEN

Begin

Result: = proxyInfo ^ .lpszproxy;

IF poschar

'=', Result) =

0

THEN

// Same Proxy for All Protocols

EXIT;

// Find Proxy For Protocol

PROXIES: = strsplitchar (Result,

');

For i: =

0

To Length (PROXIES) -

1

DO

IF strmatchleft (Proxies [i], IEPROTOPREFIX [Protocol],

False)

THEN

Begin

Result: = strafterchar (PROXIES [i],

'=');

EXIT;

END;

// no proxy forprotocol

Result: =

'';

END;

Finally

FreeMem (ProxyInfo);

END;

END;

{$ ENDIF}

Function GethardDisk SerialNumber

Const Driveletter: Char):

String;

VAR N, F, S: DWORD;

Begin

S: =

0;

GetVolumeInformation (Pchar (Driveletter

': /'), NIL, MAX_PATH

1, @S,

N, f, nil,

0);

Result: = longwordtohex (s,

8);

END;

{} {Twindowhandle}

{}

Function windowHandleMessageProc

Const windowHandle: hwnd;

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Stdcall;

VAR V: TOBJECT;

Begin

V: = TOBJECT (GetWindowlong (WindowHandle,

0)));

// Get User Data

IF v

Is TwindowHandle

THEN

Result: = twindowhandle (V) .MessageProc (MSG, WPARAM, LPARAM)

Else

Result: = DEFWINDOWPROC (WindowHandle, MSG, WPARAM, LPARAM);

// Default Handler

END;

VAR

WindowClass: TwndClass =

STYLE:

0;

LpfnWndproc: @windowhandleMessageProc;

Cbclsextra:

0;

CBWndextra: sizeof (Pointer);

// Size of extra user data

Hinstance:

0;

Hicon:

0;

Hcursor:

0;

HBRBACKGROUND:

0;

LPSZMENUNAME: NIL;

lpszclassname:

'FundamentalsWindowClass';

Destructor twindowhandle.destroy;

Begin

DestroyWindowhandle;

Inherited destroy;

END;

Procedure Twindowhandle.raiseerror

Const msg:

String);

Begin

Raise Ewindowhandle.create (MSG);

END;

Function twindowhandle.allocateWindowHandle: hwnd;

VAR C: TwndClass;

Begin

WindowClass.hinstance: = Hinstance;

// register class

IF

Not getClassInfo (Hinstance, WindowClass.lpszclassname, C)

THEN

IF Windows.RegisterClass (WindowClass) =

0

THEN

Raiseerror

'Window Class Registration Failed: Windows Error #' INTOSTR (GetLastError);

// Allocate Handle

Result: = CREATEWINDOWEX (WS_EX_TOOLWINDOW,

Windowclass.lpszclassname,

'',

{Window Name}

WS_POPUP,

{Window Style}

0,

0,

{X, y} 0,

0,

{Width, height}

0,

{hwndparent}

0,

{hmenu}

Hinstance,

{hinstance}

NIL);

{Createparam}

if Result =

0

THEN

Raiseerror

'Window Handle Allocation Failed: Windows Error #' INTOSTR (GetLastError));

// set User Data

Setwindowlong (Result,

0,

Integer (Self));

END;

Function Twindowhandle.handlewm

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Integer;

Var Handled:

Boolean;

Begin

Result: =

0;

Handled: =

False;

IF Assigned (Fonmessage)

THEN

Result: = FonMessage (MSG, WPARAM, LPARAM, HANDLED);

IF

Not handled

THEN

Result: = DEFWINDOWPROC (FwindowHandle, MSG, WPARAM, LPARAM);

// Default Handler

END;

Function Twindowhandle.MessageProc

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Integer;

Var r:

Boolean;

Begin

IF Assigned (FonbeforeMessage)

THEN

FONBEFOREMESSAGE (SELF);

R: = assigned (FonafterMessage);

Try

Try

Result: = Handlewm (MSG, WPARAM, LPARAM);

Except

ON E: Exception

DO

Begin

IF Assign (FONEXCEPTION)

THEN

FONEXCEPTION (Self, E);

Result: =

0;

END;

END;

Finally

IF r

THEN

IF Assigned (FonafterMessage)

THEN

FonafterMessage (Self);

END;

END;

Function twindowhandle.GetwindowHandle: hwnd;

Begin

Result: = fwindowhandle;

if Result =

0

THEN

Begin

FwindowHandle: = AllocateWindowHandle;

Result: = fwindowhandle;

END;

END;

Procedure twindowhandle.destroywindowhandle;

Begin

IF fwindowhandle =

0

THEN

EXIT;

// Clear User Data

Setwindowlong (FwindowHandle,

0,

0);

DestroyWindow (FWindowHandle);

FWindowHandle: =

0;

END;

Function Twindowhandle.ProcessMessage:

Boolean;

Var msg: windows.tmsg;

Begin

IF fterminated

THEN

BEGINRESULT: =

False;

EXIT;

END;

Result: = PeekMessage (MSG,

0,

0,

0, PM_Remove);

IF Result

THEN

if msg.Message = WM_QUIT

THEN

Fterminated: =

True

Else

IF fterminated

THEN

Result: =

False

Else

Begin

TranslateMessage (MSG);

DispatchMessage (MSG);

END;

END;

Procedure twindowhandle.processMessages;

Begin

While ProcessMessage

DO;

END;

Function TwindowHandle.handleMessage:

Boolean;

Var msg: windows.tmsg;

Begin

IF fterminated

THEN

Begin

Result: =

False;

EXIT;

END;

Result: = GetMessage (MSG,

0,

0,

0);

IF

NOT RESULT

THEN

Fterminated: =

True

Else

IF fterminated

THEN

Result: =

False

Else

Begin

TranslateMessage (MSG);

DispatchMessage (MSG)

END;

END;

Procedure twindowhandle.Messageloop;

Begin

While HandleMessage

DO;

END;

Procedure twindowhandle.terminate;

Begin

Fterminated: =

True;

END;

{}

{TTIMERHANDLE}

{}

Constructor TTIMERHANDLE.CREATE (Aowner: Tcomponent);

Begin

Inherited Create (Aowner);

FtimerInterval: =

1000;

END;

Procedure ttimerhandle.destroywindowhandle;

Begin

IF

Not (csdesigning

In ComponentState)

And (fwindowhandle <>

0)

and

FTIMERACTIVE

THEN

Killtimer (Fwindowhandle,

1);

Inherited DestroyWindowHandle;

END;

Function TTIMERHANDLE.DOSETTIMER:

Boolean;

Begin

IF ftimerinterval <=

0

THEN

Result: =

False

Else

Result: = setTimer (getWindowHandle,

1, ftimerinterval, nil) =

0;

END;

Procedure ttimerhandle.load;

Begin

inherited loading;

IF

Not (csdesigningin componentstate)

And ftimeractive

THEN

Dosettimer;

END;

Procedure TTIMERHANDLE.TRIGGERTIMER;

Begin

IF Assigned (Fontimer)

THEN

Fontimer (Self);

END;

Procedure TTIMERHANDLE.SETTIMERACTIVE

Const TimerActive:

Boolean;

Begin

IF ftimeractive = timeractive

THEN

EXIT;

IF [csdesigning, csloading] * ComponentState = []

THEN

IF TIMERACTIVE

THEN

Begin

IF

Not dosettimer

THEN

EXIT;

end

Else

Killtimer (Fwindowhandle,

1);

FTimeractive: = TIMERACTIVE;

END;

Function TTIMERHANDLE.HANDLEWM

CONST MSG: cardinal

Const WPARAM, LPARAM:

Integer:

Integer;

Begin

IF msg = wm_timer

THEN

Try

Result: =

0;

Triggertimer;

Except

ON E: Exception

DO

Begin

Result: =

0;

IF Assign (FONEXCEPTION)

THEN

FONEXCEPTION (Self, e);

EXIT;

END;

end

Else

Result: =

Inherited Handlewm (MSG, WPARAM, LPARAM);

END;

Initialization

Finalization

IF Assigned (VersionInfobuf)

THEN

FreeMem (VersionInfobuf);

End.