Codebox


            unit CodeBox;
{ This verison of the CodeBox unit is designed to compile on the
 Standard and Pro versions of Delphi 4. If it does not, let me
 know by email at ccalvert@borland.com.
 In particular, I have commented out the reference to HTTPApp.pas because
 it does not ship with the Pro and Standard versions of Delphi. To
 support a function in the CodeBox unit called GetWebRequest (lines 294 &
 2510) you can restore HTTPApp.pas to the uses clause and you can
 remove the comments around GetWebRequest. To edit the uses clause
 on line 24 for the CS version, make sure it looks like this:
 uses
 Windows, Classes, Forms,
 Consts, SysUtils, Graphics,
 ActiveX, HTTPApp.pas;
 ---------------------------------------------------------------
 This unit contains various utility routines that I have written
 or collected over the years.
 There are four major categories of routines:
 Bit manipulation
 Math
 Ole
 Palette
 String
 This unit will compile to a smaller size if you define
 DELPHI_LEAN_AND_MEAN. Might do that on shipping builds...
 Delphi 1 = VER80
 Delphi 2 = VER90
 Delphi 3 = VER100
 Delphi 4 = VER120
 C++ Builder = VER93
 C++ Builder3 = VER110
}
interface
uses
 Windows, Classes, Forms,
 Consts, SysUtils, Graphics,
 ActiveX;
 //, HTTPApp;
{ --- Bit Manipulation --- }
function ShowBits(B: Byte): string;
procedure SetBit(Position: Integer; Value: Byte; var ChangeByte: Byte);
function BitOn(Position: Integer; TestByte: Byte) : Boolean;
{ --- Math Declarations --- }
function ArcCos(x: Real): Real;
function ArcSin(x: Real): Real;
function Comp2Str(N: Comp): String;
function Int2StrPad0(N: LongInt; Len: Integer): String;
function Int2Str(N: LongInt): String;
function IsEqual(R1, R2: Double): Boolean;
function LogXY(x, y: Real): Real;
function Pennies2Dollars(C: Comp): String;
function Power(X: Integer; Y: Integer): Real;
function Power2(Base, Exponent : Double) : Double;
function Real2Str(N: Real; Width, Places: integer): String;
function Str2Comp(MyString: string): Comp;
function Str2Pennies(S: String): Comp;
function Str2Real(MyString: string): Double;
function XToTheY(x, y: Real): Real;
{ --- Date and Time Declarations --- }
function HoursToMsecs(Hours: Integer): Integer;
function MinutesToMSecs(Minutes: Integer): Integer;
function SecondsToMSecs(Seconds: Integer): Integer;
{ --- OLE DECLARATIONS --- }
const
 SOleError = 62211;
 CLSCTX_REMOTE_SERVER = $10;
type
 PMultiQi = ^TMultiQI;
 TMultiQi = record
 IID: PGUID;
 Unknown: IUnknown;
 hr: HRESULT;
 end;
PCoAuthIdentity = ^TCoAuthIdentity;
TCoAuthIdentity = record
// User: PUSHORT;
 UserLength: ULong;
// Domain: PUShort;
 DomainLength: ULong;
// Password: PUShort;
 PasswordLength: ULong;
 Flags: ULong;
end;
PCoAuthInfo = ^TCoAuthInfo;
TCoAuthInfo = record
 dwAuthnSvc: DWord;
 dwAuthzSvc: DWord;
 pwszServerPrincName: PWideChar;
 dwImpersonationLevel: DWord;
 pAuthIdentityData: PCoAuthIdentity;
 dwCapabilities: Dword;
end;
PCoServerInfo = ^TCoServerInfo;
TCoserverinfo = record
 dwReserved1: DWord;
 pwszName: PWideChar;
 pAuthInfo: PCoAuthInfo;
 dwReserved2: DWord;
end;
{$IFDEF VER90}
 TCoserverinfo = record
 dwReserved1: DWord;
 pwszName: PWideChar;
 pAuthInfo: PCoAuthInfo;
 dwReserved2: DWord;
 end;
 PCoServerInfo = ^TCoServerInfo;
 TCoServerInfo = record
 dwSize: DWORD;
 pszName: POleStr;
 end;
{$ENDIF}
 EOleError = class(Exception);
 PClassInfo = ^TClassInfo;
 TClassInfo = record
 FileName: string;
 ProgID: string;
 ClassID: string;
 Description: string;
 end;
 TMakeGuid = class
 private
 FClassInfo: TClassInfo;
 FGuid: TGuid;
 FClassName: string;
 function GUIDToString: string;
 protected
 public
 constructor Create(AClassName: string); virtual;
 function CreateClassInfo(FileName, ProgID, Description: string;
 UpdateReg: Boolean): TClassInfo;
 destructor Destroy; override;
 function GUIDToNewPascalRecord: string;
 function GUIDToOldPascalRecord: string;
 function GUIDToCStruct: string;
 function CreateRegFile: string;
 procedure UpdateRegistry(DoRegister: Boolean);
 function StringGUIDToPascalRecord(S: string): string;
 property GUID: TGUID read FGuid;
 property GuidAsString: string read GuidToString;
 end;
{$IFDEF VER90}
function CoCreateInstanceEx(const clsid: TGUID; unkOuter: IUnknown;
 dwClsContext: Longint; CoServer: PCoServerInfo;
 const CMQ: LongInt; rgmqResults: PMultiQI): HResult; stdcall; }
{$ENDIF}
function AnsiToUnicode(S: string; var NewSize: Integer): PWideChar;
function CLSIDToStr(ID: TGUID): string;
// function CreateRemoteOleObject(const ClassName, Server: string): Variant;
{$IFDEF VER90}
function GetRemoteOleObject(ClassID: TGUID; const Server: string): Variant;
{$ENDIF}
function CreateRemoteOleObject(ClassID: TGUID; const Server: string): Variant;
function CreateRemoteUnknown(ClassID: TGUID; const Server: string): IUnknown;
function CreateLocalOleObject(ClassID: TGUID): Variant;
procedure CreateRegKey(const Key, Value: string);
function CutDirStr(Start: string; NumDirs: Integer): string;
procedure DeleteRegKey(const Key: string);
function EnumerateClipBoardFormats(AHandle: THandle): string;
function FileNameToExe(S: string): string;
function GetAppContentType(sExt: string): string;
function GetCLSIDName(iid: TGuid): string;
function GetNameOfCLSID(iid: TGUID): string;
function GetNameOfInterfaceID(iid: TGUID): string;
function GetVarType(i: Integer): string;
function GetOleError(ErrorCode: HResult): ShortString;
function GetcfFormat(AFormat: DWord): ShortString;
function GetMediumType(tymed: Longint): string;
procedure OleError(ErrorCode: HResult);
procedure OleSucceeded(hr: HResult);
procedure SplitDirName(Path: string; var Dir: string; var WName: String);
function UnicodeToAnsi(S: PWideChar): string;
{ --- Palette Manipulation --- }
type
 T256PalEntry = array[0..255] of TPALETTEENTRY;
 PRGB = ^TRGB;
 TRGB = array[ 0..255 ] of TRGBQuad;
 { TFilePalette accepts a Paint Shop Pro text file palette
 and create a windows palette. In PSP, you can save a 256
 color palette to a text file. That is the file that
 TFilePalette works with.}
 TFilePalette = class
 private
 FDC: HDC;
 FFileName: string;
 FHandle: HWnd;
 FOldPal: HPalette;
 FPalette: HPalette;
 FPalEntries: T256PalEntry;
 function MakePalette: Boolean;
 function ReadPalette: Boolean;
 protected
 public
 constructor Create(AHandle: HWnd; AFileName: string); virtual;
 destructor Destroy; override;
 function GetPalette: HPalette;
 function RealizePalette: HDC;
 property Palette: HPalette read FPalette write FPalette;
 end;
procedure BatchBitmapToJPeg(Dir: string; DeleteOriginals: Boolean);
procedure BitmapToJPeg(FileName: string; DeleteOriginal: Boolean);
procedure DrawClock(Canvas: TCanvas; X, Y: Integer; Color: TColor);
procedure DrawPalette(DC: HDC);
function GetDCCaps(DC: HDC): string;
function GetPaletteFromResFile(Instance: THandle;
 BitmapName: string; var NumPalEntries: Integer): T256PalEntry;
procedure MakePaletteCurrent(Handle: HWnd; Pal: T256PalEntry);
procedure ReadPal(FileName: string; var P: T256PalEntry);
procedure WritePal(FileName: string; var P: T256PalEntry);
procedure AppendError(ErrorCode: HResult; ErrStr: string);
procedure SaveClipBoardBitmap(BitMap: HBitMap; FileName: string);
procedure ShowFilePalette(Handle: HWnd; AFileName: string);
function StartTimer: DWord;
function EndTimer(StartTime: DWord): DWORD;
{-------------------------------------------------------------------------------
 STRING HANDLING
 These routines are designed to make life easier when you are
 handling text. The routines are not necessarily well optimized,
 but they make it easy to write easily maintainable code for
 manipulating strings.
 TODO
 This section has some references to WIN32. Its doubtful that
 CodeBox will even come close to compiling under Delphi 1, so
 I can probably remove those references, rather than trying to
 IfDef them....
-------------------------------------------------------------------------------}
const
 CR = #13#10;
 MaxStrLen = 250;
type
 Str12 = string[12];
 DirStr = string[67];
 PathStr = string[79];
 NameStr = string[8];
 ExtStr = string[4];
function Ask(S: string): Boolean;
function Address2Str(Addr : Pointer) : string;
function AddBackSlash(S: string): string;
function CleanFTPString(S: string): string;
function CleanString(S: string): string;
function GetFirstWord(S: string): string;
function GetFirstToken(S: string; Token: Char): string;
function GetHexWord(w: Word): string;
function GetLastToken(S: string; Token: Char): string;
function GetLastWord(S: string): string;
{$IFNDEF WIN32}
function GetLogicalAddr(A: Pointer): Pointer;
{$ENDIF}
function GetTodayName(Pre, Ext: string): string;
function GetTodaysDate: string;
function GetTimeString: string;
function GetTimeFormated: string;
function IsNumber(Ch: Char): Boolean;
function LeftSet(src: string; Width:Integer; var Trunc: Boolean): String;
procedure ParseTokenList(S: string; Token: Char; var List: TStringList);
function ReplaceChars(S: string; OldCh, NewCh: Char): string;
function ReplaceCharStr(S: string; OldCh: Char; NewStr: string): string;
function RightCharSet(Src: string; Width: Integer;
 Ch: Char; var Trunc: Boolean): string;
function RemoveFirstWord(var S : String) : String;
function ReplaceString(NewSubStr, OldSubStr, WholeStr: string): string;
function ReplaceAllStrings(NewStr, ReplaceStr: string;
 Data: string): string;
function ReverseStr(S: string): string;
function Shorten(S: string; Cut: Integer): string;
function StripAllChars(S: string; Ch: Char): string;
function StripCRs(S: string): string;
function StripBackSlash(const S: String): String;
function StripBlanks(S: string): string;
function StripEndChars(S: string; Ch: Char): string;
function StripFirstWord(S : string) : string;
function StripFirstToken(S: string; Ch: Char): string;
function StripFrontChars(S: string; Ch: Char): string;
function StripFromFront(S: string; Len: Integer): string;
function StripFromEnd(S: string; Num: integer): string;
function StripLastToken(S: string; Token: Char): string;
function StripLastWord(S: string): string;
{$IFNDEF WIN32}
procedure SetLength(var S: string; i: Integer);
{$ENDIF}
function StrTok(StrToSearch, StrToFind: string): string;
procedure Tokenize (toBeTokened: string; delimiter : char;
 var tokens :array of string);
{--------------------------------------}
{-- RichEdit Code ---------------------}
{--------------------------------------}
(*
uses RichEdit;
Type
 TEditStreamCallBack = function (dwCookie : DWORD; buf : PChar;
bytestoread : LongInt; var bytesread : LongInt): DWORD; stdcall;
 TEditStream = record
 dwCookie: Longint;
 dwError: Longint;
 pfnCallback: TEditStreamCallBack;
 end;
 StreamOps = (readop, writeop);
 TRTFCookieData = {my data record} record
 streamop : readop..writeop;
 opstream : TStream;
 end;
 PRTFData = ^TRTFCookieData;
{$R *.DFM}
function EditStreamCallBack(dwCookie : DWORD; buf : PChar;
bytestoread : LongInt; var bytesread : LongInt): DWORD; stdcall;
var
 astream : TStream;
 RTFData : PRTFData;
begin
 RTFData := PRTFData(dwCookie);
 astream := RTFData.opstream;
 result := S_OK;
 bytesread := 0;
 try
 if RTFData.streamop = readop then
 bytesread := astream.Read(buf^, bytestoread)
 else
 bytesread := astream.Write(buf^, bytestoread);
 showmessage(inttostr(bytesread));
 except
 result := E_FAIL;
 end;
end;
procedure RTF_To_Stream(RE : TRichEdit; astream : TStream);
var
 CookieData : TRTFCookieData;
 EditStream : TEditStream;
begin
 CookieData.streamop := writeop;
 CookieData.opstream := astream;
 EditStream.dwCookie := DWORD(@CookieData);
 EditStream.pfnCallback := EditStreamCallBack;
 EditStream.dwError := S_OK;
 SendMessage(RE.handle, EM_STREAMOUT, SF_RTF or SFF_SELECTION,
LongInt(@EditStream));
end;
procedure RTF_From_Stream(RE : TRichEdit; astream : TStream);
var
 CookieData : TRTFCookieData;
 EditStream : TEditStream;
begin
 CookieData.streamop := readop;
 CookieData.opstream := astream;
 EditStream.dwCookie := DWORD(@CookieData);
 EditStream.pfnCallback := EditStreamCallBack;
 EditStream.dwError := S_OK;
 SendMessage(RE.handle, EM_STREAMIN, SF_RTF or SFF_SELECTION,
LongInt(@EditStream));
end;
procedure TForm1.Button2Click(Sender: TObject);
var
 ss : TStringStream;
begin
 ss := TStringStream.Create('');
 try
 RTF_To_Stream(RichEdit1, ss);
 ss.position := 0;
 RTF_From_Stream(RichEdit3, ss);
 finally
 ss.free;
 end;
end; *)
{-----------------------------------------------------------------------------
 COM STORAGE
-----------------------------------------------------------------------------}
type
 TSafeStore = class(TObject)
 private
 FStorageStrings: TStringList;
 FStorage: IStorage;
 procedure CreateStorage(FileName: string);
 procedure OpenStorage(FileName: string);
 function ShowStorageElement(S: string; StatStg: TStatStg): Integer;
 procedure HandleProperty(Storage: IStorage);
 procedure HandleSubStorage(var Storage: IStorage; StatStg: TStatStg);
 procedure EnumStorageElements(var Storage: IStorage);
 public
 destructor Destroy; override;
 function RefreshStorageStr: TStringList;
 constructor Create(FileName: string); virtual;
 procedure DestroyElement(S: string);
 function GetNewStream(StreamName: string): IStream;
 function OpenStream(StreamName: string): IStream;
 procedure WriteTextToStorage(StreamName: string; Value: string);
 function ReadTextFromStream(StreamName: string): string;
 procedure ReadInteger(Stream: IStream; var Num: Integer);
 procedure WriteInteger(Stream: IStream; Num: Integer);
 procedure ReadString(Stream: IStream; var S: string);
 procedure WriteString(Stream: IStream; S: string);
 property StgStrings: TStringList read FStorageStrings;
 property Storage: IStorage read FStorage;
 end;
procedure CreateNewFile(var F: TextFile; FileName: string);
procedure DrawBitmap(PaintDC: HDC; Bitmap: HBitMap;
 XVal, Yval, AWidth, AHeight: Integer);
function CoinFlip: Boolean;
function ReadStringFromStorage(StorageName: string; StreamName: string): string;
procedure WriteStreamToStorage(StorageName, StreamName, Value: string);
{$IFDEF VER90}
function VarToInterface(const V: Variant): IDispatch;
{$ENDIF}
procedure GetFileAttributeList(Items: TStrings; A: Integer);
//function GetWebRequest(Request: TWebRequest): string;
{-----------------------------------------------------------------------------
 FILE HANDLING
 Some of the following are from the FmxUtils.pas file that ships
 with Delphi 4 in the demos directory.
-----------------------------------------------------------------------------}
function BigFileSize(FileName: string): Int64;
function CheckExtension(FileName: string; Values: array of string): Boolean;
function GetStartDir: string;
function GetTempDir: string;
procedure GetNameAndExt(FileName: string; var Name: string; var Ext: string);
function ExecuteFile(const FileName, Params, DefaultDir: string;
 ShowCmd: Integer): THandle;
procedure EZCopyFile(const FileName, DestName: string);
procedure MoveFile(const FileName, DestName: string);
function GetFileSize2(const FileName: string): LongInt;
function FileDateTime(const FileName: string): TDateTime;
function HasAttr(const FileName: string; Attr: Word): Boolean;
function IsPrinterOn(const Port: Word): Boolean;
function IsValidDir(S: string): Boolean;
procedure WinExec2(ProgramToStart: string; Params: string; Show: Integer);
procedure WinExecAndWait(const Cmd: string; Params: string; Show: Integer);
implementation
uses
 Dialogs, ClipBrd, Registry,
 ComObj, ShellApi, jpeg,
 MMSystem;
{------------------------------------------------------------------------------
 This routine should return True 50% of the time.
 Call Randomize before calling this method
------------------------------------------------------------------------------}
function CoinFlip: Boolean;
var
 Odds: Real;
begin
 Odds := Random;
 if Odds < 0.5 then
 Result := True
 else
 Result := False;
end;
procedure CreateNewFile(var F: TextFile; FileName: string);
begin
 AssignFile(F, FileName);
 ReWrite(F);
 CloseFile(F);
end;
{** WinExec2 is a replacement for the Win16 WinExec procedure, which is
 still available, but which is officially obsolete.
 @param Show 
 The show parameter can be:
 
 SW_HIDE = 0;
 SW_SHOWNORMAL = 1;
 SW_SHOWMINIMIZED = 2;
 SW_SHOWMAXIMIZED = 3;
 
 @example
 Here is an example:
 
 WinExec2('c:\windows\notepad.exe', ' c:\autoexec.bat', SW_SHOWNORMAL);
  }
procedure WinExec2(ProgramToStart: string; Params: string; Show: Integer);
var
 StartupInfo: TStartupInfo;
 ProcessInfo: TProcessInformation;
begin
 if (Params <> '') and (Params[1] <> ' ') then
 Params := ' ' + Params;
 FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
 StartupInfo.cb := SizeOf(TStartupInfo);
 StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
 StartupInfo.wShowWindow := Show;
 if not (CreateProcess(PChar(ProgramToStart), PChar(Params), nil,
 nil, False, NORMAL_PRIORITY_CLASS, nil, nil,
 StartupInfo, ProcessInfo)) then
 RaiseLastWin32Error;
 WaitForInputIdle(ProcessInfo.hProcess, Infinite);
 CloseHandle(ProcessInfo.hThread);
 CloseHandle(ProcessInfo.hProcess);
end;
{** WinExecAndWait starts a program and wait for it to return.
 See WinExec2 above for more details.
 @example
 
 WinExecAndWait('c:\windows\notepad.exe', '', SW_SHOWNORMAL);
 ShowMessage('Call over');
  }
procedure WinExecAndWait(const Cmd: string; Params: string; Show: Integer);
var
 StartupInfo: TStartupInfo;
 ProcessInfo: TProcessInformation;
 Wait: DWord;
begin
 if (Params <> '') and (Params[1] <> ' ') then
 Params := ' ' + Params;
 FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
 StartupInfo.cb := SizeOf(TStartupInfo);
 StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
 StartupInfo.wShowWindow := Show;
 if not (CreateProcess(PChar(Cmd), PChar(Params), nil,
 nil, False, NORMAL_PRIORITY_CLASS, nil, nil,
 StartupInfo, ProcessInfo)) then
 RaiseLastWin32Error;
 WaitForInputIdle(ProcessInfo.hProcess, Infinite);
 Wait := WaitForSingleObject(ProcessInfo.hProcess, Infinite);
 case Wait of
 WAIT_ABANDONED: ;
 WAIT_OBJECT_0: ;
 WAIT_TIMEOUT: ;
 end;
 CloseHandle(ProcessInfo.hThread);
 CloseHandle(ProcessInfo.hProcess);
end;
{** Pass in a TStrings object and this routine will file it with the
 attributes from TSearchRec. Typically used with FindNext and a
 ListBox.Items object. }
procedure GetFileAttributeList(Items: TStrings; A: Integer);
begin
 if A and SysUtils.faDirectory = SysUtils.faDirectory then
 Items.Add('Directory');
 if A and faReadOnly = faReadOnly then
 Items.Add('ReadOnly');
 if A and faSysFile = faSysFile then
 Items.Add('SystemFile');
 if A and faVolumeID = faVolumeID then
 Items.Add('Volume ID');
 if A and faArchive = faArchive then
 Items.Add('Archive');
 if A and faAnyFile = faAnyFile then
 Items.Add('AnyFile');
 if A and faHidden = faHidden then
 Items.Add('Hidden');
end;
{$IFDEF VER90}
{** For use with older versions of Delphi }
function VarToInterface(const V: Variant): IDispatch;
begin
 Result := nil;
 if TVarData(V).VType = varDispatch then
 Result := TVarData(V).VDispatch
 else if TVarData(V).VType = (varDispatch or varByRef) then
 Result := Pointer(TVarData(V).VPointer^);
 if Result = nil then raise EOleError.Create(SVarNotObject);
end;
{$ENDIF}
{ ------------------------- }
{ --- BIT MANIPULATION --- }
{ ------------------------- }
{** ShowBits accepts a byte parameter and returns a string of eight ones
 and zeros indicating the binary form of a bite. }
function ShowBits(B : Byte): string;
var
 i: Integer;
 bt: Byte;
 s: string;
begin
 bt := $01;
 s := '';
 for i := 1 to 8 do begin
 if (b And bt) > 0 then
 S := '1' + s
 else
 s := '0' + s;
 {$R-}
 bt := bt shl 1;
 {$R+}
 end;
 ShowBits := s;
end;
{** SetBit sets a particular bit in ChangeByte to either 1 or 0. The bit
 is specified by Position, which can range from 0 to 7. In Value, put 1
 if you want the bit Position set to 1 and put 0 if you want bit Position
 set to 0. The right byte is Position 0, the far left is Position 7.
 Based on a routine found in Turbo Pascal by Stephen K O'Brian. }
procedure SetBit(Position : Integer; Value : Byte; var ChangeByte : Byte);
var
 Bt : Byte;
begin
 bt := $01;
 bt := bt shl Position;
 if Value = 1 then
 ChangeByte := ChangeByte or bt
 else begin
 bt := bt xor $FF;
 ChangeByte := ChangeByte and bt;
 end;
end;
{** BitOn tests if a bit in TestByte is turned on (equal to 1).
 If the bit indicated by Position is turned on, then BitOn returns True. }
function BitOn(Position : Integer; TestByte : Byte) : Boolean;
var
 bt : Byte;
begin
 bt := $01;
 bt := bt shl Position;
 BitOn := (bt and TestByte) > 0;
end;
{ ------------------------ }
{ --- MATH ROUTINES --- }
{ ------------------------ }
{** ArcCos Find the ArcCos of a Real
 Date: 02/20/94 }
function ArcCos(x: Real): Real;
begin
 ArcCos := ArcTan(Sqrt(1 - Sqr(x)) / x);
end;
{**

 Name: ArcSin function
Declaration: function ArcSin(x: Real): Real;
 Unit: MathBox
 Code: N
 Date: 02/20/94
Description: Find the ArcSin of a Real
}
function ArcSin(x: Real): Real;
begin
 ArcSin := ArcTan(x / Sqrt( 1 - Sqr(x)));
end;
{** 
 Name: Comp2Str function
Declaration: Comp2Str(N: real; Width, Places: integer)
 Unit: MathBox
 Code: N
 Date: 02/17/94
Description: Converts a Comp into a String
 }
function Comp2Str(N: Comp): String;
var
 TempString: String;
begin
 Str(N:0:0, TempString);
 Comp2Str := TempString;
end;
{** 
 Name: Int2Str function
Declaration: Int2Str(N: LongInt): String;
 Unit: MathBox
 Code: N
 Date: 06/25/94
Description: Converts a number into a string and pads
 the string with zeros if it is less than
 Len characters long.
 }
function Int2Str(N: LongInt): String;
var
 S : String;
begin
 Str(N:0,S);
 Int2Str := S;
end;
{** 
 Name: Int2StrPad0 function
Declaration: Int2StrPad0(N: LongInt; Len: Integer): String;
 Unit: MathBox
 Code: N
 Date: 03/01/94
Description: Converts a number into a string and pads
 the string with zeros if it is less than
 Len characters long.
 }
function Int2StrPad0(N: LongInt; Len: Integer): string;
begin
 FmtStr(Result, '%d', [N]);
 while Length(Result) < Len do
 Result := '0' + Result;
end;
{** 
 Name: IsEqual function
Declaration: IsEqual(R1, R2: Double): Boolean;
 Unit: MathBox
 Code: N
 Date: 07/04/94
Description: Tests to see if two doubles are effectively
 equal. Floating point numbers are never
 exact, so we need an approximation.
 }
function IsEqual(R1, R2: Double): Boolean;
var
 R : Double;
begin
 R := Abs(R1 - R2);
 if R > 0.0001 then
 IsEqual := False
 else
 IsEqual := True;
end;
{** 
 Name: LogXY function
Declaration: function LogXY(x: Real): Real;
 Unit: MathBox
 Code: N
 Date: 02/20/94
Description: Log of X Y
 }
function LogXY(x, y: Real): Real;
begin
 LogXY := Ln(x) / Ln(y);
end;
{** 
 Name: Pennies2Dollars function
Declaration: Pennies2Dollars(C: Comp): String;
 Unit: MathBox
 Code: N
 Date: 02/17/94
Description: Converts a Comp type that represents a
	 certain number of pennies into a string
 with two decimal places. 123 => $1.23
 }
function Pennies2Dollars(C: Comp): String;
var
 S: string;
begin
 S := Comp2Str(C);
 Insert('.', S, Length(S) - 1);
 if S[1] = '-' then begin { Number negative? }
 S := StripFrontChars(S, '-');
 S := '-$' + S;
 end else
 S := '$' + S;
 Pennies2Dollars := S;
end;
{** 
 Name: Power function
Declaration: Power(X: Integer; Y: Integer): Real;
 Unit: MathBox
 Code: N
 Date: 02/20/94
Description: Raise X to the Y power
 }
function Power(X: Integer; Y: Integer): Real;
var
 Count: Integer;
 OutCome: Real;
begin
 OutCome := 1;
 for Count := 1 to Y do
 OutCome := OutCome * X;
 Power := OutCome;
end;
{** A power function from Jack Lyle. Said to be more powerful than the
 Pow function that comes with Delphi. }
function Power2(Base, Exponent : Double) : Double;
{ raises the base to the exponent }
 CONST
 cTiny = 1e-15;
 VAR
 Power : Double; { Value before sign correction }
 BEGIN
 Power := 0;
 { Deal with the near zero special cases }
 IF (Abs(Base) < cTiny) THEN BEGIN
 Base := 0.0;
 END; { IF }
 IF (Abs(Exponent) < cTiny) THEN BEGIN
 Exponent := 0.0;
 END; { IF }
 { Deal with the exactly zero cases }
 IF (Base = 0.0) THEN BEGIN
 Power := 0.0;
 END; { IF }
 IF (Exponent = 0.0) THEN BEGIN
 Power := 1.0;
 END; { IF }
 { Cover everything else }
 IF ((Base < 0) AND (Exponent < 0)) THEN
 Power := 1/Exp(-Exponent*Ln(-Base))
 ELSE IF ((Base < 0) AND (Exponent >= 0)) THEN
 Power := Exp(Exponent*Ln(-Base))
 ELSE IF ((Base > 0) AND (Exponent < 0)) THEN
 Power := 1/Exp(-Exponent*Ln(Base))
 ELSE IF ((Base > 0) AND (Exponent >= 0)) THEN
 Power := Exp(Exponent*Ln(Base));
 { Correct the sign }
 IF ((Base < 0) AND (Frac(Exponent/2.0) <> 0.0)) THEN
 Result := -Power
 ELSE
 Result := Power;
 END; { FUNCTION Pow }
{** 
 Name: Real2Str function
Declaration: Real2Str(N: real; Width, Places: integer)
 Unit: MathBox
 Code: N
 Date: 02/17/94
Description: Converts a Real number into a String
 }
function Real2Str(N: Real; Width, Places: integer): String;
var
 TempString: String;
begin
 Str(N:Width:Places, TempString);
 Real2Str := TempString;
end;
{** 
 Name: Str2Comp function
Declaration: Str2Real(MyString: string)
 Unit: MathBox
 Code: N
 Date: 02/17/94
Description: Converts a String to a Comp
 }
function Str2Comp(MyString: string): Comp;
var
 ErrCode: Integer;
 Temp: Comp;
begin
 If Length(Mystring) = 0 then Str2Comp := 0
 else begin
 Val(Mystring, Temp, ErrCode);
 if ErrCode = 0 then
 Str2Comp := temp
 else
 Str2Comp := 0;
 end;
end;
{** 
 Name: Str2Pennies function
Declaration: Str2Pennies(MyString: string)
 Unit: MathBox
 Code: N
 Date: 02/17/94
Description: Converts a String to a Comp
 }
function Str2Pennies(S: String): Comp;
var
 C: Comp;
 i: Integer;
 begin
 if S[1] = '$' then Delete(S, 1, 1);
 i := Pos('.', S);
 if i = Length(S) then begin { Is last character a period? }
 Delete(S, i, 1);
 S := S + '00';
 end else
 if i <> 0 then begin { Some pennies? }
 Delete(S, i, 1);
 if i = (Length(S)) then { Only one char after decimal?}
 S := S + '0'
 end else
 S := S + '00'; { No decimal, no pennies }
 C := Str2Comp(S);
 Str2Pennies := C;
end;
{** 
 Name: Str2Real function
Declaration: Str2Real(MyString: string)
 Unit: MathBox
 Code: N
 Date: 02/17/94
Description: Converts a String to Real number
 }
function Str2Real(MyString: string): Double;
var
 ErrCode: Integer;
 Temp: Double;
begin
 If Length(Mystring) = 0 then Str2Real := 0
 else begin
 Val(Mystring, Temp, ErrCode);
 if ErrCode = 0 then
 Str2Real := temp
 else
 Str2Real := 0;
 end;
end;
{** 
 Name: XToTheY function
Declaration: XToTheY(x, y: Real): Real;
 Unit: MathBox
 Code: N
 Date: 02/20/94
Description: Raise X to the Y Power
 }
function XToTheY(x, y: Real): Real;
begin
 XToTheY := Exp(y * Ln(x));
end;
{ ------------------------------------------------------ }
{ --- DateTime ROUTINES ------------------------------ }
{ ------------------------------------------------------ }
function HoursToMsecs(Hours: Integer): Integer;
begin
 Result := Hours * 60 * 60 * 1000;
end;
function MinutesToMSecs(Minutes: Integer): Integer;
begin
 Result := Minutes * 60 * 1000;
end;
function SecondsTOMSecs(Seconds: Integer): Integer;
begin
 Result := Seconds * 1000;
end;
{ ------------------------------------------------------ }
{ --- OLE ROUTINES ----------------------------------- }
{ ------------------------------------------------------ }
{ --- TMakeGuid --- }
// Not exactly rocket science....
constructor TMakeGuid.Create(AClassName: string);
begin
 CoInitialize(nil);
 CoCreateGuid(FGUID);
 FClassName := AClassName;
end;
destructor TMakeGuid.Destroy;
begin
 CoUninitialize;
 inherited Destroy;
end;
function TMakeGuid.GUIDToString: string;
var
 P: PWideChar;
begin
 StringFromCLSID(FGUID, P);
 Result := WideCharToString(P);
end;
function TMakeGuid.StringGuidToPascalRecord(S: string): string;
var
 Len, i: Integer;
begin
 S := ReplaceString('D1:$', '{', S);
 S := ReplaceString(';D2:$', '-', S);
 S := ReplaceString(';D3:$', '-', S);
 S := ReplaceString(';D4:($', '-', S);
 S := ReplaceString(',$', '-', S);
 S := ReplaceString('));', '}', S);
 for i := 1 to 7 do begin
 Len := Length(S);
 if i <> 6 then
 Insert(',$', S, Len - (4 * i));
 end;
 S := ' CLSID_' + FClassName + ': TGUID = (' + #13#10#32#32#32#32 + S;
 Result := S;
end;
// Convert Windows GUID to old Delphi GUID
function TMakeGuid.GUIDToNewPascalRecord: string;
var
 S: string;
begin
 S := GUIDToString;
 Result := 'LIBID_Project1: TGUID = ''' + S + ''';';
end;
// Convert Windows GUID to old Delphi GUID
function TMakeGuid.GUIDToOldPascalRecord: string;
var
 S: string;
begin
 S := GUIDToString;
 Result := StringGuidToPascalRecord(S);
end;
function TMakeGuid.GUIDToCStruct: string;
var
 Len, i: Integer;
 AClassName, S: string;
begin
 AClassName := UpperCase(FClassName);
 S := GuidToString;
 S := ReplaceString('0x', '{', S);
 S := ReplaceString(', 0x', '-', S);
 S := ReplaceString(', 0x', '-', S);
 S := ReplaceString(', 0x', '-', S);
 S := ReplaceString('', '-', S);
 S := ReplaceString(');', '}', S);
 for i := 1 to 7 do begin
 Len := Length(S);
 Insert(',0x', S, Len - (3 + ((i - 1) * 5)));
 end;
 S := 'DEFINE_GUID(CLSID_' + AClassname + ', ' + S;
 Result := S;
end;
function TMakeGuid.CreateRegFile: string;
var
 GuidAsString: string;
const
 RegString = 'REGEDIT' + CR +
 'HKEY_CLASSES_ROOT\%s1.0 = %s Object' + CR +
 'HKEY_CLASSES_ROOT\%s1.0\CLSID = %s' + CR +
 'HKEY_CLASSES_ROOT\%s = %s Object' + CR +
 'HKEY_CLASSES_ROOT\%s\CurVer = %s1.0' + CR +
 'HKEY_CLASSES_ROOT\%s\CLSID = %s' + CR +
 'HKEY_CLASSES_ROOT\CLSID\%s = %s Object'+ CR +
 'HKEY_CLASSES_ROOT\CLSID\%s\ProgID = %s1.0' + CR +
 'HKEY_CLASSES_ROOT\CLSID\%s\VersionIndependentProgID = %s' + CR +
 'HKEY_CLASSES_ROOT\CLSID\%s\InprocServer32 = e:\src\Maze\%s\%s.dll' + CR +
 'HKEY_CLASSES_ROOT\CLSID\%s\NotInsertable';
begin
 GuidAsString := GUIDToString;
 Result := Format(RegString, [FClassName, FClassName, FClassName, GuidAsString,
 FClassName, FClassName, FClassName, FClassName, FClassName, GuidAsString,
 GuidAsString, FClassName, GuidAsString, FClassName, GuidAsString, FClassName, GuidAsString, FClassName,
 FClassName, GuidAsString]);
end;
function TMakeGuid.CreateClassInfo(FileName, ProgID, Description: string;
 UpdateReg: Boolean): TClassInfo;
begin
 FClassInfo.ClassID := GUIDAsString;
 FClassInfo.FileName := FileName;
 FClassInfo.ProgID := ProgID;
 FClassInfo.Description := Description;
 If UpdateReg then UpdateRegistry(True);
 Result := FClassInfo;
end;
/////////////////////////////////////////////////
// Given a TClassInfo structure, as defined in this unit,
// either register, or unregister the class in the
// registration database. Use REGEDIT.EXE to view results.
/////////////////////////////////////////////////
procedure TMakeGuid.UpdateRegistry(DoRegister: Boolean);
begin
 if DoRegister then begin
 CreateRegKey(FClassInfo.ProgID, FClassInfo.Description);
 CreateRegKey(FClassInfo.ProgID + '\Clsid', FClassInfo.ClassID);
 CreateRegKey('CLSID\' + FClassInfo.ClassID, FClassInfo.Description);
 CreateRegKey('CLSID\' + FClassInfo.ClassID + '\ProgID', FClassInfo.ProgID);
 CreateRegKey('CLSID\' + FClassInfo.ClassID + '\InprocServer32', FClassInfo.FileName);
 end else begin
 DeleteRegKey('CLSID\' + FClassInfo.ClassID + '\InprocServer32');
 DeleteRegKey('CLSID\' + FClassInfo.ClassID + '\ProgID');
 DeleteRegKey('CLSID\' + FClassInfo.ClassID);
 DeleteRegKey(FClassInfo.ProgID + '\Clsid');
 DeleteRegKey(FClassInfo.ProgID);
 end;
end;
{ This function returns the size of the allocated string in NewSize.
 YOu have to free up this memory yourself. }
function AnsiToUnicode(S: string; var NewSize: Integer): PWideChar;
var
 Size: Integer;
 P: PWideChar;
begin
 Size := Length(S);
 NewSize := Size * 2;
 P := VirtualAlloc(nil, Size, Mem_Commit, Page_ReadWrite);
 MultiByteToWideChar(CP_ACP, 0, PChar(S), Size, P, NewSize);
 Result := P;
end;
function CLSIDToStr(ID: TCLSID): string;
var
 hr: hResult;
 WideString: PWideChar;
begin
 hr := StringFromCLSID(ID, WideString);
 if Failed(hr) then OleError(hr);
 Result := UnicodeToAnsi(WideString);
end;
const
 ole32 = 'ole32.dll';
{$IFDEF VER90}
function CoCreateInstanceEx; external ole32 name 'CoCreateInstanceEx';
{$ENDIF}
// Thanks to Serge Shalatski  for his
// improvements to GetRemoteOleObject, CreateRemoteUnknown, and
// CreateLocalOleObject. 
{$IFDEF VER90}
function GetRemoteOleObject(ClassID: TGUID; const Server: string): Variant;
var
 Unknown: IUnknown;
 ClassFactory: IClassFactory;
 Info: TCoServerInfo;
 Dest: Array[0..127] of WideChar;
begin
 ClassFactory := nil;
 Info.dwReserved1 := 0;
 Info.pwszName := StringToWideChar(Server, Dest, SizeOf(Dest) div 2);
 Info.pAuthInfo := nil;
 Info.dwReserved2 := 0;
 OleCheck( CoGetClassObject(ClassID,
 CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER,
 @Info, IClassFactory, ClassFactory));
 if ClassFactory = nil then
 ShowMessage('No Class Factory')
 else
 ClassFactory.CreateInstance(nil, IUnknown, Unknown);
 Result := Unknown as IDispatch;
end;
{$ENDIF}
function CreateRemoteUnknown(ClassID: TGUID; const Server: string): IUnknown;
var
 Info: TCoServerInfo;
 Dest: Array[0..127] of WideChar;
 MultiQI: TMultiQi;
 Guid: TGuid;
begin
 Guid := IDispatch;
 MultiQi.IID := @Guid;
 MultiQI.Unknown := nil;
 FillChar(Info, sizeOF(Info), #0);
 Info.pwszName := StringToWideChar(Server, Dest, SizeOf(Dest) div 2);
 OleCheck(CoCreateInstanceEx(ClassID, nil,
 CLSCTX_LOCAL_SERVER or CLSCTX_REMOTE_SERVER or CLSCTX_INPROC_SERVER,
 @Info, 1, @MultiQI));
 Result := MultiQI.Unknown;
end;
function CreateRemoteOleObject(ClassID: TGUID; const Server: string): Variant;
begin
 Result := CreateRemoteUnknown(ClassID, Server) as IDispatch;
end;
function CreateLocalOleObject(ClassID: TGUID): Variant;
var
 Unknown: IUnknown;
 ClassFactory: IClassFactory;
begin
 ClassFactory := nil;
 OleCheck(CoGetClassObject(ClassID, CLSCTX_LOCAL_SERVER, nil,
 IClassFactory, ClassFactory));
 if ClassFactory = nil then
 ShowMessage('No Class Factory')
 else
 ClassFactory.CreateInstance(nil, IUnknown, Unknown);
 Result := Unknown as IDispatch;
end;
(*
function CreateRemoteUnknown(ClassID: TGUID; const Server: string): IUnknown;
var
 Info: TCoServerInfo;
 Dest: Array[0..127] of WideChar;
 MultiQI: TMultiQi;
 Guid: TGuid;
begin
 Guid := IDispatch;
 MultiQi.IID := @Guid;
 MultiQI.Unknown := nil;
 FillChar(Info, sizeOF(Info), #0);
 Info.pwszName := StringToWideChar(Server, Dest, SizeOf(Dest) div 2);
 OleCheck(CoCreateInstanceEx(ClassID, nil, CLSCTX_REMOTE_SERVER,
 @Info, 1, @MultiQI));
 Result := MultiQI.Unknown;
end;
function CreateRemoteOleObject(ClassID: TGUID; const Server: string): Variant;
begin
 Result := CreateRemoteUnknown(ClassID, Server) as IDispatch;
end;
function CreateLocalOleObject(ClassID: TGUID): Variant;
var
 Unknown: IUnknown;
 ClassFactory: IClassFactory;
begin
 ClassFactory := nil;
 OleCheck(CoGetClassObject(ClassID, CLSCTX_LOCAL_SERVER, nil,
 IClassFactory, ClassFactory));
 if ClassFactory = nil then
 ShowMessage('No Class Factory')
 else
 ClassFactory.CreateInstance(nil, IUnknown, Unknown);
 try
 Result := Unknown;
 finally
 //ClassFactory.Release;
// Unknown.Release;
 end;
end; *)
procedure CreateRegKey(const Key, Value: string);
begin
 RegSetValue(HKEY_CLASSES_ROOT, PChar(Key), REG_SZ, PChar(Value),
 Length(Value));
end;
procedure DeleteRegKey(const Key: string);
begin
 RegDeleteKey(HKEY_CLASSES_ROOT, PChar(Key));
end;
// Don't use this function. Its just a test
// routine. I need to do more research into the
// poorly documented FindExecutable function
function FileNameToExe(S: string): string;
var
 Str: PChar;
begin
 GetMem(Str, 1024);
 FindExecutable(PChar(S), nil, Str);
 Result := Str;
 FreeMem(Str, 1024);
end;
{This function will return the type of the application that windows has
assciated with the extension. If you modified the function you proberly could
get the GUID and COM Server information.}
function GetAppContentType(sExt: String): String;
var
 Reg: TRegistry;
 sKey: String;
begin
 Result := 'application/unknown';
 If Pos('.', sExt) = 0 Then
 Begin
 sKey := '.' + sExt;
 End
 Else
 Begin
 sKey := sExt;
 End;
 Reg := TRegistry.Create;
 Reg.RootKey := HKEY_CLASSES_ROOT;
 If Reg.KeyExists(sKEY) Then
 Begin
 If Reg.OpenKey(sKEY, False) Then
 Begin
 Try
 Result := Reg.ReadString('Content Type');
 Except
 Result := 'application/' + sKEY;
 End;
 End;
 End;
 Reg.Free;
end;
function GetCLSIDName(iid: TCLSID): string;
var
 S: string;
begin
 if IsEqualIID(iid, IUnknown) then
 S := 'IID_IUnknown'
 else if IsEqualIID(iid, IClassFactory) then
 S := 'IID_IClassFactory'
 else if IsEqualIID(iid, IMarshal) then
 S := 'IID_IMarshal'
 else if IsEqualIID(iid, IStdMarshalInfo) then
 S := 'IID_IStdMarshalInfo'
 else if IsEqualIID(iid, IExternalConnection) then
 S := 'IID_IExternalConnection'
 else
 S := CLSIDToStr(iid);
 Result := S;
end;
function GetNameOfCLSID(iid: TIID): string;
var
 Registry: TRegistry;
 S: string;
 P: PWideChar;
begin
 OleCheck(StringFromCLSID(iid, P));
 S := WideCharToString(P);
 Registry := TRegistry.Create;
 Registry.RootKey := HKEY_CLASSES_ROOT;
 Registry.OpenKey('CLSID', False);
 Registry.OpenKey(S, False);
 Result := Registry.ReadString('');
 Registry.Free;
end;
function GetNameOfInterfaceID(iid: TIID): string;
var
 Registry: TRegistry;
 S: string;
 P: PWideChar;
begin
 OleCheck(StringFromCLSID(iid, P));
 S := WideCharToString(P);
 Registry := TRegistry.Create;
 Registry.RootKey := HKEY_CLASSES_ROOT;
 Registry.OpenKey('Interface', False);
 Registry.OpenKey(S, False);
 Result := Registry.ReadString('');
 if Result = '' then
 Result := 'Could Not Find ID: ' + S;
 Registry.Free;
end;
procedure OleError(ErrorCode: HResult);
var
 Message: string;
begin
 Message := SysErrorMessage(ErrorCode);
 if Message = '' then FmtStr(Message, LoadStr(SOleError), [ErrorCode]);
 raise EOleError.Create(Message);
end;
procedure OleSucceeded(hr: HResult);
begin
 if not Succeeded(hr) then
 OleError(hr);
end;
function GetOleError(ErrorCode: HResult): ShortString;
var
 S: string;
begin
 S := SysErrorMessage(ErrorCode);
 if S = '' then
 FmtStr(S, LoadStr(SOleError), [ErrorCode]);
 Result := 'GetOleError: ' + S;
end;
function GetVarType(i: Integer): string;
var
 S: string;
begin
 case i of
 varEmpty: S := 'varEmpty';
 varNull: S := 'VarNull';
 varSmallint: S := 'varSmallInt';
 varInteger: S := 'varInteger';
 varSingle: S := 'varSingle';
 varDouble: S := 'varDouble';
 varCurrency: S := 'varCurrency';
 varDate: S := 'varData';
 varOleStr: S := 'varOleStr';
 varDispatch: S := 'varDispatch';
 varError: S := 'varError';
 varBoolean: S := 'varBoolean';
 varVariant: S := 'varVariant';
 varUnknown: S := 'varUnknown';
 varByte: S := 'varByte';
 varString: S := 'varString';
 varTypeMask: S := 'varTypeMask';
 varArray: S := 'varArray';
 varByRef: S := 'varByRef';
 else
 S := 'Unknown - That is, I don''t know what it is.';
 end;
 Result := S;
end;
function GetcfFormat(AFormat: DWord): ShortString;
var
 S: ShortString;
 Temp: PChar;
 Len: Integer;
begin
 case AFormat of
 CF_TEXT: S := 'CF_TEXT';
 CF_BITMAP: S := 'CF_BITMAP';
 CF_METAFILEPICT: S := 'CF_METAFILEPICT';
 CF_SYLK: S := 'CF_SYLK';
 CF_DIF: S := 'CF_DIF';
 CF_TIFF: S := 'CF_TIFF';
 CF_OEMTEXT: S := 'CF_OEMTEXT';
 CF_DIB: S := 'CF_DIB';
 CF_PALETTE: S := 'CF_PALETTE';
 CF_PENDATA: S := 'CF_PENDATA';
 CF_RIFF: S := 'CF_RIFF';
 CF_WAVE: S := 'CF_WAVE: 12';
 CF_UNICODETEXT: S := 'CF_UNICODETEXT: 13';
 CF_ENHMETAFILE: S := 'CF_ENHMETAFILE: 14';
 CF_HDROP: S := 'CF_HDROP: 15';
 CF_LOCALE: S := 'CF_LOCAL: $10';
 CF_MAX: S := 'CF_MAX: 17';
 CF_OWNERDISPLAY: S := 'CF_OWNERDISPLAY: 128';
 CF_DSPTEXT: S := 'CF_DSPTEXT: 129';
 CF_DSPBITMAP: S := 'CF_DSPBITMAP';
 CF_DSPMETAFILEPICT: S := 'CF_DSPMETAFILEPICT';
 CF_DSPENHMETAFILE: S := 'CF_DSPENHMETAFILE';
 { "Private" formats don't get GlobalFree()'d }
 CF_PRIVATEFIRST: S := 'CF_PRIVATEFIRST';
 CF_PRIVATELAST: S := 'CF_PRIVATELAST';
 { "GDIOBJ" formats do get DeleteObject()'d }
 CF_GDIOBJFIRST: S := 'CF_GDIOBJFIRST';
 CF_GDIOBJLAST: S := 'CF_GDIOBJLAST';
 //-1: S := 'Sent -1 (wildcard?)';
 else
 GetMem(Temp, MaxStrLen + 1);
 Len := GetClipboardFormatName(AFormat, Temp, MaxStrLen);
 if Len = 0 then
 S := Format('Not recognized: %d %x', [AFormat, AFormat])
 else
 S := Temp;
 FreeMem(Temp, MaxStrLen + 1);
 end;
 Result := S;
end;
function EnumerateClipBoardFormats(AHandle: THandle): string;
var
 Format: Integer;
 S: ShortString;
begin
 S := '';
 Format := 0;
 OpenClipBoard(AHandle);
 repeat
 Format := EnumClipBoardFormats(Format);
 if Format <> 0 then
 S := S + GetcfFormat(Format) + CR;
 until Format = 0;
 CloseClipBoard;
 Result := S;
end;
function GetMediumType(tymed: Longint): string;
var
 S: string;
begin
 case tymed of
 TYMED_HGLOBAL : S := 'TYMED_HGLOBAL';
 TYMED_FILE : S := 'TYMED_FILE';
 TYMED_ISTREAM : S := 'TYMED_ISTREAM';
 TYMED_ISTORAGE : S := 'TYMED_ISTORAGE';
 TYMED_GDI : S := 'TYMED_GDI';
 TYMED_MFPICT : S := 'TYMED_MFPICT';
 TYMED_ENHMF : S := 'TYMED_ENHMF';
 TYMED_NULL : S := 'TYMED_NULL';
 -1 : S := 'Sent - 1';
 else
 S := 'Unknown Type';
 end;
 Result := S;
end;
// Assumes you are passing in a string of type: c:\Temp\Sam\*.*
// This will return c:\Temp\
// If you pass in c:\Temp\Sam you will get c:\ 
// If you pass in c:\Temp\Sam\ then it will return c:\Temp\
function CutDirStr(Start: String; NumDirs: Integer): String;
var
 i, j: Integer;
 CurDir: string;
 FileMask: string;
begin
 SplitDirName(Start, CurDir, FileMask);
 CurDir := AddBackSlash(CurDir);
 i := Length(CurDir);
 for j := 1 to NumDirs do begin
 if CurDir[i] = '\' then begin
 CurDir := Shorten(CurDir, 1);
 Dec(i);
 end;
 while CurDir[i] <> '\' do begin
 CurDir := Shorten(CurDir, 1);
 Dec(i);
 end;
 end;
 Result := CurDir;
end;
procedure SplitDirName(Path: string; var Dir: string; var WName: string);
begin
 Dir := ExtractFilePath(Path);
 WName := ExtractFileName(Path);
end;
function UnicodeToAnsi(S: PWideChar): string;
var
 S1: PChar;
 i: Integer;
begin
 i := lstrlenw(S) + 1;
 GetMem(S1, 500);
 WideCharToMultiByte(CP_ACP, 0, S, i, S1, i * 2, nil, nil);
 Result := S1;
 FreeMem(S1, 500);
end;
{ ------------------------------------------------------ }
{ --- PALETTE ROUTINES --------------------------------- }
{ ------------------------------------------------------ }
{ --- TFilePalette --- }
constructor TFilePalette.Create(AHandle: HWnd; AFileName: string);
begin
 FHandle := AHandle;
 FFileName := AFilename;
 FDC := GetDC(FHandle);
end;
destructor TFilePalette.Destroy;
begin
 if FPalette <> 0 then
 DeleteObject(FPalette);
 if FDC <> 0 then begin
 SelectPalette(FDC, FOldPal, True);
 ReleaseDC(FHandle, FDC);
 end;
 inherited Destroy;
end;
{ Call only if you are not calling RealizePalette }
function TFilePalette.GetPalette: HPalette;
begin
 ReadPalette;
 MakePalette;
 Result := FPalette;
end;
function TFilePalette.MakePalette: Boolean;
var
 Log: PLogPalette;
begin
 GetMem(Log, 4 + (256 * SizeOf(TPaletteEntry)));
 Log^.palVersion := $300;
 Log^.palNumEntries := 256;
 Move(FPalEntries, Log^.palPalEntry, SizeOf(T256PalEntry));
 FPalette := CreatePalette(Log^);
 FreeMem(Log, 4 + (256 * SizeOf(TPaletteEntry)));
 Result := True;
end;
{ Automatically calls GetPallette }
function TFilePalette.RealizePalette: HDC;
begin
 GetPalette;
 FOldPal := SelectPalette(FDC, FPalette, True);
 Windows.RealizePalette(FDC);
 Result := FDC;
end;
function TFilePalette.ReadPalette: Boolean;
begin
 ReadPal(FFileName, FPalEntries);
 Result := True;
end;
{ --- Misc Routines --- }
procedure BatchBitmapToJPeg(Dir: string; DeleteOriginals: Boolean);
var
 SR: TSearchRec;
 FindResult: Integer;
begin
 SetCurrentDir(Dir);
 FindResult := FindFirst('*.bmp', faAnyFile, SR);
 if FindResult = 0 then
 repeat
 if SR.Name <> '' then
 BitmapToJPeg(Dir + SR.Name, True);
 until FindNext(SR) <> 0;
 FindClose(SR);
end;
procedure BitmapToJPeg(FileName: string; DeleteOriginal: Boolean);
var
 Bitmap: TBitmap;
 JPeg: TJPegImage;
begin
 Bitmap := TBitmap.Create;
 Bitmap.LoadFromFile(FileName);
 JPeg := TJPegImage.Create;
 JPeg.Assign(Bitmap);
 JPeg.SaveToFile(ChangeFileExt(FileName, '.jpg'));
 JPeg.Free;
 Bitmap.Free;
 if DeleteOriginal then
 DeleteFile(FileName);
end;
procedure DrawClock(Canvas: TCanvas; X, Y: Integer; Color: TColor);
const
 Border = 10;
var
 S: string;
 HalfTextWidth: Integer;
 HalfTextHeight: Integer;
begin
 S := DateTimeToStr(Now);
 HalfTextWidth := (Canvas.TextWidth(S) div 2);
 HalfTextHeight := (Canvas.TextHeight(S) div 2);
 Canvas.Brush.Color := Color;
 Canvas.Ellipse((X - HalfTextWidth) - Border, (Y - HalfTextHeight) - Border,
 X + HalfTextWidth + Border, Y + HalfTextHeight + Border);
 SetBkMode(Canvas.Handle, Transparent);
 Canvas.TextOut(X - HalfTextWidth , Y - HalfTextHeight, S);
end;
procedure DrawPalette(DC: HDC);
var
 i, j: Integer;
 AColor: TColorRef;
 AnIndex, X, Y: Integer;
 OldBrush: HBrush;
 Brush: TBrush;
begin
 AnIndex := 0;
 Brush := TBrush.Create;
 for j := 1 to 16 do
 for i := 0 to 15 do begin
 X := i * 25 + 10;
 Y := j * 25 + 10;
 AColor := PaletteIndex(AnIndex);
 Brush.Color := AColor;
 OldBrush := SelectObject(DC, Brush.Handle);
 Rectangle(DC, X, Y, X + 15, Y + 15);
 SelectObject(DC, OldBrush);
 Inc(AnIndex);
 end;
 Brush.Free;
end;
procedure MakePaletteCurrent(Handle: HWnd; Pal: T256PalEntry);
var
 OldPal, hPal: hPalette;
 Log: PLogPalette;
 DC: HDC;
begin
 DC := GetDC(Handle);
 GetMem(Log, 4 + (256 * SizeOf(TPaletteEntry)));
 Log^.palVersion := $300;
 Log^.palNumEntries := 256;
 Move(Pal, Log^.palPalEntry, SizeOf(Pal));
 hPal := CreatePalette(Log^);
 OldPal := SelectPalette(DC, hPal, True);
 ShowMessage(IntToStr( RealizePalette(DC) ));
 SelectPalette(DC, OldPal, True);
 DeleteObject(hPal);
 ReleaseDC(Handle, DC);
 FreeMem(Log, 4 + (256 * SizeOf(TPaletteEntry)));
end;
function GetPaletteFromResFile(Instance: THandle;
 BitmapName: string; var NumPalEntries: Integer): T256PalEntry;
var
 h: HRsrc;
 BitmapInfo: PBitmapInfo;
 RGB: PRGB;
 i: Integer;
 APE: T256PalEntry;
 GLobal: HGlobal;
begin
 h := FindResource(Instance, PChar(BitmapName), RT_BITMAP);
 if h = 0 then begin
 raise Exception.Create('Can''t load resource in GetPaletteFromResFile');
 Exit;
 end;
 AppendError(0, 'H Exists');
 if h <> 0 then begin
 Global := LoadResource(Instance, h);
 BitmapInfo := PBitmapInfo(LockResource(Global));
 RGB := PRGB(@BitmapInfo^.bmiColors);
 if (BitmapInfo = NIL) or
 (BitmapInfo^.bmiHeader.biSize < sizeof(TBITMAPINFOHEADER)) then
 NumPalEntries := 0
 else
 if (BitmapInfo^.bmiHeader.biBitCount > 8) then NumPalEntries := 0
 else
 if (BitmapInfo^.bmiHeader.biClrUsed = 0) then
 NumPalEntries := 1 SHL BitmapInfo^.bmiHeader.biBitCount
 else
 NumPalEntries := BitmapInfo^.bmiHeader.biClrUsed;
 // a DIB color table has its colors stored BGR not RGB
 // so flip them around.
 AppendError(0, 'NumPalEntries: ' + IntToStr(NumPalEntries));
 for i := 0 to NumPalEntries - 1 do with APE[ i ], RGB^[ i ] do begin
 peRed := rgbRed;
 peGreen := rgbGreen;
 peBlue := rgbBlue;
 peFlags := 0;
 end;
 FreeResource(Global);
 end;
 Result := APE;
end;
procedure SaveClipBoardBitmap(BitMap: HBitMap; FileName: string);
var
 B: Graphics.TBitmap;
begin
 B := TBitMap.Create;
 B.Assign(ClipBoard);
 B.SaveToFile(FileName);
 B.Free;
end;
{procedure WriteError(ErrorCode: HResult);
var
 Message: string;
 F: Text;
begin
 Message := SysErrorMessage(ErrorCode);
 if Message = '' then FmtStr(Message, LoadStr(62211), [ErrorCode]);
 Assign(F, 'c:\err.txt');
 ReWrite(F);
 WriteLn(F, Message, ' Code: ', ErrorCode);
 Close(F);
end; }
procedure AppendError(ErrorCode: HResult; ErrStr: string);
var
 Message: string;
 F: Text;
begin
 Message := SysErrorMessage(ErrorCode);
 if Message = '' then FmtStr(Message, LoadStr(62211), [ErrorCode]);
 Assign(F, 'c:\err.txt');
 try
 Append(F);
 except
 ReWrite(F);
 end;
 WriteLn(F, Message, ' Code: ', ErrorCode, ' ', ErrStr);
 Close(F);
end;
{procedure GetColors(S: String; P: TRGBQuad);
begin
 WriteLn(S);
 P.rgbBlue := 1;
end; }
procedure ShowFilePalette(Handle: HWnd; AFileName: string);
var
 FilePal: TFilePalette;
 ADC: HDC;
begin
 FilePal := TFilePalette.Create(Handle, AFileName);
 ADC := FilePal.RealizePalette;
 DrawPalette(ADC);
 FilePal.Free;
end;
{ This is one of those text version of palettes like PSP creates }
procedure ReadPal(FileName: string; var P: T256PalEntry);
var
 F: Text;
 i: Integer;
 S: String;
begin
 Assign(F, FileName);
 Reset(F);
 ReadLn(F, S);
 ReadLn(F, S);
 ReadLn(F, S);
 for i := 0 to 255 do begin
 ReadLn(F, p[i].peRed, p[i].peGreen, p[i].peblue);
 P[i].peFlags := PC_NOCOLLAPSE;
 end;
 Close(F);
end;
procedure WritePal(FileName: string; var P: T256PalEntry);
var
 F: Text;
 i: Integer;
begin
 Assign(F, FileName);
 ReWrite(F);
 WriteLn(F, 'JASC-PAL');
 WriteLn(F, '0100');
 WriteLn(F, '256');
 for i := 0 to 255 do
 WriteLn(F, P[i].peRed, ' ', P[i].peGreen, ' ', P[i].peBlue);
 Close(F);
end;
{procedure ShowFH(D: TBitMapFileHeader);
begin
 WriteLn('File Header');
 WriteLn('===========');
 WriteLn('Type: ', Chr(Lo(D.bfType)), Chr(Hi(D.bfType)));
 WriteLn('Size: ', D.bfSize);
 WriteLn('Offset: ', D.bfOffBits);
end; }
{function GetPaletteSize(Info: TBitMapInfoHeader): LongInt;
begin
 if Info.biSize = SizeOf(TBitMapCoreHeader) then
 GetPaletteSize := Info.biClrUsed * SizeOf(TRGBTriple)
 else
 GetPaletteSize := Info.biClrUsed * SizeOf(TRGBQuad);
end; }
{** Show the capabilities of a device context }
function GetDCCaps(DC: HDC): string;
const
 CR = #13#10;
var
 S: string;
begin
 S := Format('BitsPerPixel: %d' + CR +
 'Color Planes: %d' + CR +
 'Num Colors: %d',
 [GetDeviceCaps(DC, BitsPixel),
 GetDeviceCaps(DC, Planes),
 GetDeviceCaps(DC, NumColors)]);
 Result := S;
end;
{** For use when timing how long a chunk of code takes to execute. Profiling. 
 @seeAlso EndTimer
 @Example
 Here is an example of how to use the StartTimer and EndTimer
 functions:
procedure TForm1.DoWith;
begin
 with Paintbox1.canvas do begin
 font.color:=clGreen;
 TextOut(12,12,'GreenText');
 end;
end;
procedure TForm1.DoWithOut;
begin
 PaintBox1.Canvas.Font.Color := clGreen;
 PaintBox1.Canvas.TextOut(12,12,'Green Text');
end;
procedure TForm1.Button1Click(Sender: TObject);
var
 ATime: DWord;
 i: Integer;
begin
 ATime := StartTimer;
 for i := 1 to 1000 do DoWithOut;
 Edit2.Text := IntToStr(EndTimer(ATime));
 ATime := StartTimer;
 for i := 1 to 1000 do DoWith;
 Edit1.Text := IntToStr(EndTimer(ATime));
end;}
function StartTimer: DWORD;
begin
 Result := TimeGetTime;
end;
{** For use when profiling a chunk of code 
 @seeAlso StartTimer }
function EndTimer(StartTime: DWord): DWORD;
begin
 Result := TimeGetTime - StartTime;
end;
{ ------------------------ }
{ --- STRING ROUTINES --- }
{ ------------------------ }
{$IFNDEF WIN32}
{** If you are using Delphi 1.0, support the Delphi Win32 SetLength function }
procedure SetLength(var S: string; i: Integer);
begin
 S[0] := Chr(i);
end;
{$ENDIF}
{** Ask the user a question and get a Boolean yes/no response }
function Ask(S: string): Boolean;
begin
 if MessageDlg(S, mtConfirmation, mbOkCancel, 0) = idOk then
 Result := True
 else
 Result := False;
end;
{** Convert the address of a pointer to a string }
function Address2Str(Addr: Pointer): string;
begin
 Result := Format('%p', [Addr]);
end;
{** Append a backslash to a string. For use with directory strings. }
function AddBackSlash(S: string): string;
var
 Temp: string;
begin
 Temp := S;
 if S[Length(Temp)] <> '\' then
 Temp := Temp + '\';
 AddBackSlash := Temp;
end;
{** When listing FTP directories, clean up the string so it
 has the right number of slashes.}
function CleanFTPString(S: string): string;
begin
 S := ReplaceAllStrings('/', '//', S);
 if S[Length(S)] <> '/' then
 S := S + '/';
 Result := S;
end;
{** 
 Name: CleanString function
Declaration: CleanString(S: String): string;
 Unit: StrBox
 Code: S
 Date: 05/05/94
Description: Erase blanks from end and beginning of
 a string
 }
function CleanString(S: string): string;
var
 Temp: String;
begin
 Temp := ''; 
 if Length(S) <> 0 then begin
 Temp := StripFrontChars(S, #32);
 Temp := StripEndChars(Temp, #32);
 end;
 CleanString := Temp;
end;
{** 
 Name: GetFirstWord function
Declaration: GetFirstWord(var S: string): string;
 Unit: StrBox
 Code: S
 Date: 05/02/94
Description: Get the first word from a string
 }
function GetFirstWord(S: string): string;
 Var
 i: Integer;
 S1: String;
begin
 i := 1;
 SetLength(S1, 250); // Large buffer, changed later
 while (S[i] <> ' ') and (i < Length(S)) do begin
 S1[i] := S[i];
 Inc(i);
 end;
 Dec(i);
 SetLength(S1, i);
 GetFirstWord := S1;
end;
{** Convert a Word into a Hex String. For example convert 16 to 0F }
function GetHexWord(w: Word): string;
const
 HexChars: array [0..$F] of Char = '0123456789ABCDEF';
var
 Addr: string;
begin
 Addr[1] := hexChars[Hi(w) shr 4];
 Addr[2] := hexChars[Hi(w) and $F];
 Addr[3] := hexChars[Lo(w) shr 4];
 Addr[4] := hexChars[Lo(w) and $F];
 SetLength(Addr, 4);
 GetHexWord := addr;
end;
{** Get the first n letters from a string, where the number of letters in n
 is determined by a Token. For instance, get the first word from a sentence }
function GetFirstToken(S: string; Token: Char): string;
var
 Temp: string;
 Index: INteger;
begin
 Index := Pos(Token, S);
 if Index < 1 then begin
 GetFirstToken := '';
 Exit;
 end;
 Dec(Index);
 SetLength(Temp, Index); 
 Move(S[1], Temp[1], Index);
 GetFirstToken := Temp;
end;
{** Get the last part of a string, from a token onward.
 Given "Sam.Txt", and "." as a token, this returns "Txt"
 @seeAlso GetLastWord }
function GetLastToken(S: string; Token: Char): string;
var
 Temp: string;
 Index: INteger;
begin
 S := CleanString(S);
 S := ReverseStr(S);
 Index := Pos(Token, S);
 if Index < 1 then begin // <= ???
 GetLastToken := '';
 Exit;
 end;
 Dec(Index);
 SetLength(Temp, Index);
 Move(S[1], Temp[1], Index);
 GetLastToken := ReverseStr(Temp);
end;
{** Get the last word in a string delimited by spaces
 @seeAlso GetLastToken }
function GetLastWord(S: string): string;
begin
 Result := GetLastToken(S, ' ');
end;
{** 
 Name: GetLogicalAddress function
Declaration: GetLogicalAddr(A: Pointer): Pointer;
 Unit: StrBox
 Code: S
 Date: 02/09/95
Description: Enter a physical address and this function
 will return a logical address.
 }
{$ifdef OLDDELPHI}
function GetLogicalAddr(A: Pointer): Pointer;
var
 APtr: Pointer;
begin
 if A = nil then exit;
 if Ofs(A) = $FFFF then exit;
 asm
 mov ax, A.Word[0]
 mov dx, A.Word[2]
 mov es,dx
 mov dx,es:Word[0]
 mov APtr.Word[0], ax
 mov APtr.Word[2], dx
 end;
 GetLogicalAddr := APtr;
end;
{$endif}
{** Get time in a string formated like this: 12:58:16 PM 
 @seeAlso GetTimeFormated }
function GetTimeString: string;
begin
 Result := TimeToStr(Time);
end;
{** Get the current time in a string formated like this: 12:56:10
 @seeAlso GetTimeString }
function GetTimeFormated: string;
var
 h, m, s, hund: Word;
begin
 DecodeTime(Time, h, m, s, hund);
 GetTimeFormated:= Int2StrPad0(h, 2) + ':' +
 Int2StrPad0(m, 2) + ':' + Int2StrPad0(s, 2);
end;
{** Get the directory from which a program was launched, and make sure it
 has a backslash in the last position }
function GetStartDir: string;
begin
 Result := ExtractFilePath(ParamStr(0));
 if Result[Length(Result)] <> '\' then
 Result := Result + '\';
end;
{** Get the temporary directory on a Windows machine }
function GetTempDir: string;
var
 TempPath: PChar;
begin
 GetMem(TempPath, 1024);
 GetTempPath(1024, TempPath);
 Result := TempPath;
 FreeMem(TempPath, 1024);
end;
{** 
 Name: GetTodayName function
Declaration: GetTodayName(Pre, Ext: string): string;
 Unit: StrBox
 Code: S
 Date: 03/01/94
Description: Return a filename of type PRE0101.EXT,
 where PRE and EXT are user supplied strings,
 and 0101 is today's date.
 }
function GetTodayName(Pre, Ext: string): string;
var
 y, m, d: Word;
 Year: String;
begin
 DecodeDate(Date,y,m,d);
 Year := Int2StrPad0(y, 4);
 Delete(Year, 1, 2);
 GetTodayName := Pre + Int2StrPad0(m, 2) + Int2StrPad0(d, 2) +
 Year + '.' + Ext;
end;
{** 
 Name: GetTodaysDate function
Declaration: GetTodaysDate: string;
 Unit: StrBox
 Code: S
 Date: 08/16/94
Description: Return a string of type MM/DD/YY.
 }
function GetTodaysDate: string;
var
 y, m, d: Word;
 Year: String;
begin
 DecodeDate(Date, y,m,d);
 Year := Int2StrPad0(y, 4);
 Delete(Year, 1, 2);
 GetTodaysDate := Int2StrPad0(m, 2) + '/' + Int2StrPad0(d, 2) + '/' + Year;
end;
function IsNumber(Ch: Char): Boolean;
begin
 IsNumber := ((Ch >= '0') and (Ch <= '9'));
end;
{** 
 Name: LeftSet function
Declaration: LeftSet(src: string; Width: Integer;
 var Trunc: Boolean): string;
 Code: S
 Date: 03/01/94
Description: Pad a string on the left
 }
function LeftSet(src: string; Width: Integer; var Trunc: Boolean): String;
var
 I: Integer;
 Temp: string[80];
begin
 Trunc := False;
 Temp := src;
 if(Length(Temp) > Width) and (Width > 0) then begin
 Temp[0] := CHR(Width);
 Trunc := True;
 end else
 for i := Length(Temp) to width do
 Temp := Temp + ' ';
 LeftSet := Temp;
end;
{** Given a string delimineted by a token, parse the string, and put
 the results in a TStringList. Pass in an initialized TStringList. }
procedure ParseTokenList(S: string; Token: Char; var List: TStringList);
begin
 if List = nil then Exit;
 while Pos(Token, S) <> 0 do begin
 List.Add(GetFirstToken(S, Token));
 S := StripFirstToken(S, Token);
 end;
 if S <> '' then
 List.Add(S);
end;
{** 
 Name: RemoveFirstWord function
Declaration: RemoveFirstWord(var S: String): String;
 Unit: StrBox
 Code: S
 Date: 03/02/94
Description: Strip the first word from a sentence,
 return word and a shortened sentence.
 Return an empty string if there is no
 first word.
 }
function RemoveFirstWord(var S: String): String;
var
 i, Size: Integer;
 S1: String;
begin
 i := Pos(#32, S);
 if i = 0 then begin
 RemoveFirstWord := '';
 Exit;
 end;
 SetLength(S1, i);
 Move(S[1], S1[1], i);
 SetLength(S1, i-1);
 Size := (Length(S) - i);
 Move(S[i + 1], S[1], Size);
 SetLength(S, Size);
 RemoveFirstWord := S1;
end;
{** Replace all instances of a substring within a string with a new string }
function ReplaceAllStrings(NewStr, ReplaceStr: string;
 Data: string): string;
begin
 while Pos(ReplaceStr, Data) > 0 do
 Data := ReplaceString(NewStr, ReplaceStr, Data);
 Result := Data;
end;
{** 
 Name: ReplaceString
Declaration: ReplaceString(NewStr, ReplaceStr, Data: string): string;
 Code: S
 Date: 06/06/95
Description: Given a long string, replace one substring with another.
 Given the string: "Football Delight"
 the job is to replace the word Delight with Night:
 S := ReplaceString('Night', 'Delight', 'Football Delight');
 where S ends up equaling "Football Night'; 
 }
function ReplaceString(NewSubStr, OldSubStr, WholeStr: string): string;
var
 OffSet: Integer;
begin
 OffSet := Pos(OldSubStr, WholeStr);
 Delete(WholeStr, OffSet, Length(OldSubStr));
 Insert(NewSubStr, WholeStr, OffSet);
 Result := WholeStr;
end;
{** This function replaces all intances of a single character with
 a string.
 @seeAlso ReplaceChars }
function ReplaceCharStr(S: string; OldCh: Char; NewStr: string): string;
var
// Len: Integer;
 i: Integer;
 Done: Boolean;
begin
 Done := False;
// Len := Length(S);
 i := 1;
 while not Done do begin
 if S[i] = OldCh then begin
 Delete(S, i, 1);
 Insert(NewStr, S, i);
 Inc(i, Length(NewStr));
 end else
 Inc(i);
 if i > Length(S) then Done := True;
 end;
 Result := S;
end;
{** Given a string, replace all instances of certin character with
 characters of a given value.
 @seeAlso ReplaceCharStr }
function ReplaceChars(S: string; OldCh, NewCh: Char): string;
var
 Len: Integer;
 i: Integer;
begin
 Len := Length(S);
 for i := 1 to Len do
 if S[i] = OldCh then
 S[i] := NewCh;
 Result := S;
end;
{** Reverse the characters in a string. If you pass in Summer you get back
 remmuS. }
function ReverseStr(S: string): string;
var
 Len: Integer;
 Temp: String;
 i,j: Integer;
begin
 Len := StrLen(PChar(S)); // Length returns allocation, not length
 SetLength(Temp, Len);
 j := Len;
 for i := 1 to Len do begin
 Temp[i] := S[j];
 dec(j);
 end;
 ReverseStr := Temp;
end;
{** Pad a string to a specified width with a specified character.
 @param Src the string to pad
 @param Width How wide the string should be when done
 @param Ch The character with which to pad the string
 @param Trunc Should the string by truncated if it is longer than Width?
 @returns The newly padded string }
function RightCharSet(Src: string; Width: Integer;
 Ch: Char; var Trunc: Boolean): String;
var
 I: Integer;
 Temp: string[80];
begin
 Trunc := False;
 Temp := Src;
 if(Length(Temp) > Width) and (Width > 0) then begin
 Temp[0] := CHR(Width);
 Trunc := True;
 end else
 for i := Length(Temp) to (width - 1) do
 Temp := Ch + Temp;
 RightCharSet := Temp;
end;
{** Cut the length of a string by n characters
 @param S The string to shorten
 @param Cut How much to cut it by
 @returns The shortened string }
function Shorten(S: string; Cut: Integer): string;
begin
 SetLength(S, Length(S) - Cut);
 Shorten := S;
end;
{** Remove rightmost n characters
 @param S The string to clean
 @param Ch The character to remove
 @returns The cleaned string. }
function StripAllChars(S: string; Ch: Char): string;
var
 i: Integer;
begin
 i := Length(S);
 while (Length(S) > 0) and (i > 0) do begin
 if S[i] = Ch then
 Delete(S,i,1);
 Dec(i);
 end;
 Result := S;
end;
{** Removes trailing backslash from S, if one exists }
function StripBackSlash(const S: string): string;
begin
 Result := S;
 if Result[Length(Result)] = '\' then
 Result := Shorten(Result, 1);
end;
{** 
 Name: StripBlanks function
Declaration: function StripBlanks(var S: string): String;
 Code: S
Description: Strip any stray spaces from the end of
 a string. Use StripEndChars instead.
 }
function StripBlanks(S: string): string;
begin
 Result := StripEndChars(S, #32);
end;
{** Remove carraige returns from the end of a string }
function StripCRs(S: string): string;
var
 i: Integer;
begin
 i := Length(S);
 while (i > 0) and (Length(S) > 0) do begin
 if ((S[i] = #13) or (S[i] = #10)) then begin
 Delete(S,i,1);
 if (i >= 2) and (i < Length(S)) then
 if IsCharAlpha(S[i - 1]) and IsCharAlpha(S[i + 1]) then
 Insert(' ', S, i);
 end;
 Dec(i);
 end;
 StripCrs := S;
end;
function StripEndChars(S: string; Ch: Char): string;
var
 i: Cardinal;
begin
 i := StrLen(PChar(S));
 SetLength(S, i);
 while (StrLen(PChar(S)) <= i) and (StrLen(PChar(S)) > 0) and (S[i] = Ch) do begin
 Delete(S,i,1);
 Dec(i);
 end;
 StripEndChars := S;
end;
function StripFirstToken(S: string; Ch: Char): string;
var
 i, Size: Integer;
begin
 i := Pos(Ch, S);
 if i = 0 then begin
 StripFirstToken := S;
 Exit;
 end;
 Size := (Length(S) - i);
 Move(S[i + 1], S[1], Size);
 SetLength(S, Size);
 StripFirstToken := S;
end;
{** 
 Name: StripFirstWord function
Declaration: StripFirstWord(S: string): string;
 Unit: StrBox
 Code: S
 Date: 03/02/94
Description: Strip the first word from a sentence,
 return the shortened sentence. Return original
 string if there is no first word.
 }
function StripFirstWord(S: string): string;
var
 i, Size: Integer;
begin
 i := Pos(#32, S);
 if i = 0 then begin
 StripFirstWord := S;
 Exit;
 end;
 Size := (Length(S) - i);
 Move(S[i + 1], S[1], Size);
 SetLength(S, Size);
 StripFirstWord := S;
end;
{** 
 Name: StripFrontChars function
Declaration: StripFrontChars(S: string; Ch: Char): String;
 Unit: StrBox
 Code: S
 Date: 03/02/94
Description: Strips any occurances of charact Ch that
 might precede a string.
 }
function StripFrontChars(S: string; Ch: Char): string;
begin
 while (Length(S) > 0) and (S[1] = Ch) do
 S := Copy(S,2,Length(S) - 1);
 StripFrontChars := S;
end;
function StripFromEnd(S: string; Num: integer): string;
begin
 Result := Copy(S, (Length(s) - Num + 1), Num);
end;
function StripFromFront(S: string; Len: Integer): string;
begin
 S := ReverseStr(S);
 S := Shorten(S, Len);
 S := ReverseStr(S);
 StripFromFront := S;
end;
{** 
 Name: StripLastToken function
Declaration: function StripLastToken(var S: String): String;
 Unit: CodeBox
 Code: S
 Date: 03/02/94
Description: Given a string like "c:\sam\file.txt"
 This returns: "c:\sam"
 But not specific to files any token will do
 }
function StripLastToken(S: string; Token: Char): string;
var
 Temp: string;
 Index: INteger;
begin
 S := ReverseStr(S);
 Index := Pos(Token, S);
 Inc(Index);
 Temp := Copy(S, Index, Length(S) - (Index - 1));
 StripLastToken := ReverseStr(Temp);
end;
function StripLastWord(S: string): string;
begin
 S := ReverseStr(S);
 Result := ReverseStr(StripFirstWord(S));
end;
function StrTok(StrToSearch, StrToFind: string): string;
var
 Index: Integer;
begin
 Index := Pos(StrToFind, StrToSearch);
 Result := StripFromFront(StrToSearch, Index);
end;
{** Thanks to Rene Veerman rene@xs4all.nl }
procedure Tokenize (toBeTokened: string; delimiter: char;
 var tokens: array of string);
var
 i, j, tc: Integer;
begin
 i := 0;
 j := 0;
 tc := low(tokens);
 while i < length(toBeTokened) do begin
 if toBeTokened[i] = delimiter then begin
 tokens[tc] := copy(toBeTokened, j, i-j);
 j := i;
 Inc(tc);
 if tc > high(tokens) then
 raise exception.create ('pass a bigger output array');
 end;
 Inc (i);
 end;
end;
{ --- Storage Code --- }
constructor TSafeStore.Create(FileName: string);
begin
 inherited Create;
 FStorageStrings := TStringList.Create;
 if not FileExists(FileName) then
 CreateStorage(FileName)
 else
 OpenStorage(FileName);
end;
destructor TSafeStore.Destroy;
begin
 FStorageStrings.Free;
// FStorage.Release;
 inherited Destroy;
end;
procedure TSafeStore.CreateStorage(FileName: string);
var
 Hr: HResult;
 Dest: array[0..127] of WideChar;
begin
 hr := StgCreateDocFile(StringToWideChar(FileName, Dest, SizeOf(Dest) div 2),
 STGM_DIRECT or STGM_CREATE or STGM_WRITE or STGM_SHARE_EXCLUSIVE,
 0, FStorage);
 OleCheck(hr);
end;
{** 
 Name: OpenStorage
Declaration: OpenStorage(FileName: string);
 Unit: Main
Description: Given a filename, try to open it as a storage
 file.
 }
procedure TSafeStore.OpenStorage(FileName: string);
var
 hr: HResult;
 S: PWideChar;
 Size: Integer;
 Failed: Boolean;
begin
 Failed := False;
 S := nil;
 try
 try
 S := AnsiToUnicode(FileName, Size);
 hr := StgIsStorageFile(S);
 if hr <> NoError then
 raise Exception.Create('Not a valid storage file.');
 FStorageStrings.Add('Storage ' + FileName);
 hr := StgOpenStorage(S, nil,
 Stgm_Direct or Stgm_ReadWrite or Stgm_Share_Exclusive,
 nil, LongInt(nil), FStorage);
 if ActiveX.Failed(hr) then
 raise Exception.Create('Call to StgOpenStorage failed');
 except
 Failed := True;
 raise;
 end; { try..except }
 finally
 VirtualFree(S, Size, Mem_Release);
 end; { try..finally }
 if not Failed then begin
 EnumStorageElements(FStorage);
 end;
end;
function Test(hr: HResult): Boolean;
begin
 if Succeeded(hr) then
 Result := True
 else begin
 ShowMessage('Enum Failed');
 Result := False;
 end;
end;
{** 
 Name: HandleProperty
Declaration:
 Unit: Main
Description: Show Summary Info
 }
procedure TSafeStore.HandleProperty(Storage: IStorage);
begin
 { Not Implemented }
end;
{** 
 Name: ShowStorageElement
Declaration: ShowStringType(S: string; StatStg: TStatStg);
 Unit: Main
Description: Nonroot storage elements may have a first
 character between #1 and #6 that has a special meaning.
 We deal with that here.
 }
function TSafeStore.ShowStorageElement(S: string; StatStg: TStatStg): Integer;
var
 Temp: string;
begin
 if S = 'Unknown' then begin
 StgStrings.Add('End Storage (Unknown)');
 Result := -1;
 Exit;
 end;
 {$IFDEF VER100}
 Temp := UnicodeToAnsi(StatStg.pwcsName) + ' Size: ' + IntToStr(Round(StatStg.cbSize));
 {$ELSE}
 Temp := UnicodeToAnsi(StatStg.pwcsName) + ' Size: ' + IntToStr(StatStg.cbSize);
 {$ENDIF}
 case Temp[1] of
 #1,#2,#3,#4,#6: Temp := '(Special: ' +
 IntToStr(Ord(Temp[1])) + ') ' +
 StripFromFront(Temp, 1);
 #5: begin
 Temp := StripFromFront(Temp, 1);
 Temp := '(Property) ' + Temp;
 end;
 end;
 StgStrings.Add(S + ' ' + Temp);
 Result := Ord(Temp[1]);
end;
procedure TSafeStore.HandleSubStorage(var Storage: IStorage; StatStg: TStatStg);
var
 hr: HResult;
 SubStorage: IStorage;
begin
 hr := Storage.OpenStorage(StatStg.pwcsName, nil,
 Stgm_Read or Stgm_Share_Exclusive,
 nil, LongInt(nil), SubStorage);
 if Succeeded(hr) then
 EnumStorageElements(SubStorage)
 else
 ShowMessage('Count not open subStorage');
end;
{** 
 Name: EnumStorageElements
Declaration: EnumStorageElements(var Storage: IStorage);
 Unit: Main
Description: Enumerate the elements inside a storage.
 This is a recursive routine, but the
 recursion occurs in the HandleSubStorage routine.
 }
procedure TSafeStore.EnumStorageElements(var Storage: IStorage);
var
 Enum: IEnumStatStg;
 hr: hResult;
 StatStg: TStatStg;
 Count: LongInt;
 S: string;
begin
 if not Test(FStorage.EnumElements(0, nil, 0, Enum)) then Exit;
 repeat
 hr := Enum.Next(1, StatStg, @Count);
 OleCheck(hr);
 case StatStg.dwType of
 STGTY_STREAM: S := 'Stream';
 STGTY_STORAGE: S := 'Storage';
 STGTY_LOCKBYTES: S := 'LockBytes';
 STGTY_PROPERTY: S := 'Property';
 else
 S := 'Unknown';
 end;
 if ShowStorageElement(S, StatStg) = 5 then
 HandleProperty(Storage);
 if S = 'Storage' then HandleSubStorage(Storage, StatStg);
 until HR <> S_OK;
 // Enum.Release;
end;
procedure TSafeStore.DestroyElement(S: string);
var
 Dest: array[0..127] of WideChar;
begin
 FStorage.DestroyElement(StringToWideChar(S, Dest, SizeOf(Dest) div 2));
end;
{** You must Release the stream when done: Stream.Release; Stream is for
 writing only }
function TSafeStore.GetNewStream(StreamName: string): IStream;
var
 Hr: HResult;
 Stream: IStream;
 Dest: array[0..127] of WideChar;
begin
 Hr := FStorage.CreateStream(StringToWideChar(StreamName, Dest, SizeOf(Dest) div 2),
 STGM_DIRECT or STGM_CREATE or STGM_READWRITE or STGM_SHARE_EXCLUSIVE , 0, 0, Stream);
 OleCheck(HR);
 Result := Stream;
end;
function TSafeStore.OpenStream(StreamName: string): IStream;
var
 Hr: HResult;
 Stream: IStream;
 Dest: array[0..127] of WideChar;
begin
 Hr := FStorage.OpenStream(
 StringToWideChar(StreamName, Dest, SizeOf(Dest) div 2), nil,
 STGM_DIRECT or STGM_READWRITE or STGM_SHARE_EXCLUSIVE , 0, Stream);
 OleCheck(HR);
 REsult := Stream;
end;
procedure TSafeStore.ReadInteger(Stream: IStream; var Num: Integer);
var
 Size: Integer;
begin
 OleCheck(Stream.Read(@Num, SizeOf(Integer), @Size));
 if Size <> SizeOf(Integer) then
 raise Exception.Create(Self.ClassName + '.ReadInteger');
end;
procedure TSafeStore.WriteInteger(Stream: IStream; Num: Integer);
var
 Size: Integer;
 hr: Integer;
begin
 hr := Stream.Write(@Num, SizeOf(Integer), @Size);
 OleCheck(hr);
 if Size <> SizeOf(Integer) then
 raise Exception.Create(Self.ClassName + '.WriteInteger');
end;
procedure TSafeStore.ReadString(Stream: IStream; var S: string);
var
 Num: Integer;
 Size: Integer;
begin
 ReadInteger(Stream, Num);
 SetLength(S, Num + 1);
 Stream.Read(Pointer(S), Num, @Size);
 S[Num + 1] := #0;
end;
procedure TSafeStore.WriteString(Stream: IStream; S: string);
var
 Size: Integer;
begin
 WriteInteger(Stream, Length(S));
 OleCheck(Stream.Write(PChar(S), Length(S), @Size));
 if Size <> Length(S) then
 raise Exception.Create('Stream');
end;
{** Assumes the whole stream will be one string.
 Use if you have a block of text you want to write to storage.
 It's like having a way to create a text file in a storage
 Use with ReadText from stream. }
procedure TSafeStore.WriteTextToStorage(StreamName: string; Value: string);
var
 Hr: HResult;
 Stream: IStream;
 Size: LongInt;
 Dest: array[0..127] of WideChar;
begin
 Hr := FStorage.CreateStream(StringToWideChar(StreamName, Dest, SizeOf(Dest) div 2),
 STGM_DIRECT or STGM_CREATE or STGM_WRITE or STGM_SHARE_EXCLUSIVE , 0, 0, Stream);
 OleCheck(HR);
 Stream.Write(Pointer(Value), Length(Value), @Size);
 if Size <> Length(Value) then ShowMessage('Wrong size written');
 // Stream.Release;
end;
function TSafeStore.ReadTextFromStream(StreamName: string): string;
var
 Stream: IStream;
 hr: HResult;
 S: PChar;
 Size, ASize: LongInt;
 Dest: array [0..127] of WideChar;
 StatStg: TStatStg;
begin
 hr := FStorage.OpenStream(StringToWideChar(StreamName, Dest, SizeOf(Dest) div 2), nil, STGM_DIRECT or STGM_READ or STGM_SHARE_EXCLUSIVE,
 0, Stream);
 OleCheck(hr);
 Stream.Stat(StatStg, StatFlag_Default);
 {$IFDEF VER100}
 Size := Round(StatStg.cbSize);
 {$ELSE}
 Size := StatStg.cbSize;
 {$ENDIF}
 GetMem(S, Size + 1);
 Stream.Read(S, Size, @ASize);
 S[Size] := #0;
 Result := S;
 FreeMem(S, Size + 1);
 // Stream.Release;
end;
function TSafeStore.RefreshStorageStr: TStringList;
begin
 EnumStorageElements(FStorage);
 Result := FStorageStrings;
end;
{ === End === }
function ReadStringFromStorage(StorageName: string; StreamName: string): string;
var
 Storage: IStorage;
 Stream: IStream;
 hr: HResult;
 S: PChar;
 Size, ASize: LongInt;
 Dest: array [0..127] of WideChar;
 StatStg: TStatStg;
begin
 hr := StgOpenStorage(StringToWideChar(StorageName, Dest, SizeOf(Dest) div 2), nil, STGM_DIRECT or STGM_READ or STGM_SHARE_EXCLUSIVE,
 nil, 0, Storage);
 OleCheck(hr);
 hr := Storage.OpenStream(StringToWideChar(StreamName, Dest, SizeOf(Dest) div 2), nil, STGM_DIRECT or STGM_READ or STGM_SHARE_EXCLUSIVE,
 0, Stream);
 OleCheck(hr);
 Stream.Stat(StatStg, StatFlag_Default);
 {$IFDEF VER100}
 Size := Round(StatStg.cbSize);
 {$ELSE}
 Size := StatStg.cbSize;
 {$ENDIF}
 GetMem(S, Size + 1);
 Stream.Read(S, Size, @ASize);
 S[Size] := #0;
 Result := S;
 FreeMem(S, Size + 1);
 //Stream.Release;
// Storage.Release;
end;
{** Given an existing IStorage file, add a new stream to it.
 Will create an IStorage file if none exists
 For now, this function is meant to work with strings }
procedure WriteStreamToStorage(StorageName, StreamName, Value: string);
var
 Hr: HResult;
 Storage: IStorage;
 Stream: IStream;
 Size: LongInt;
 Dest: array[0..127] of WideChar;
begin
 if FileExists(StorageName) then begin
 StgOpenStorage(StringToWideChar(StorageName, Dest, SizeOf(Dest) div 2),
 nil, Stgm_Direct or Stgm_ReadWrite or Stgm_Share_Exclusive,
 nil, LongInt(nil), Storage);
 end else begin
 Hr := StgCreateDocFile(StringToWideChar(StorageName, Dest, SizeOf(Dest) div 2),
 STGM_DIRECT or STGM_CREATE or STGM_WRITE or STGM_SHARE_EXCLUSIVE,
 0, Storage);
 if Hr <> S_OK then
 ShowMessage('Err');
 end;
 Hr := Storage.CreateStream(StringToWideChar(StreamName, Dest, SizeOf(Dest) div 2),
 STGM_DIRECT or STGM_CREATE or STGM_WRITE or STGM_SHARE_EXCLUSIVE , 0, 0, Stream);
 OleCheck(HR);
 Stream.Write(PChar(Value), Length(Value), @Size);
 if Size <> Length(Value) then ShowMessage('Wrong size written');
 // Stream.Release;
// Storage.Release;
end;
(*
function GetWebRequest(Request: TWebRequest): string;
const
 CR = '
';
var
 i: Integer;
 S: string;
begin
 S := '';
 S := 'Request.Accept: ' + Request.Accept;
 S := S + CR + 'Request.Authorization: ' + Request.Authorization;
 S := S + CR + 'Request.CacheControl: ' + Request.CacheControl;
 S := S + CR + 'Request.Connection: ' + Request.Connection;
 S := S + CR + 'Request.Content: ' + Request.Content;
 S := S + CR + 'Request.ContentEncoding: ' + Request.ContentEncoding;
 S := S + CR + 'Request.ContentType: ' + Request.ContentType;
 S := S + CR + 'ContentFields.Count: ' + IntToStr(Request.ContentFields.Count);
 for i := 0 to Request.ContentFields.Count - 1 do
 S := S + CR + 'ContentFields: ' + Request.ContentFields.Strings[i];
 S := S + CR + 'Request.ContentVersion: ' + Request.ContentVersion;
 S := S + CR + 'Request.Cookie: ' + Request.Cookie;
 S := S + CR + 'Request.Data: ' + DateToStr(Request.Date);
 S := S + CR + 'Request.From: ' + Request.From;
 S := S + CR + 'Request.Host: ' + Request.Host;
 S := S + CR + 'Method: ' + Request.Method;
 S := S + CR + 'MethodType: ' + IntToStr(Ord(Request.MethodType));
 S := S + CR + 'Request.Query: ' + Request.Query;
 S := S + CR + 'Request.Query.Count: ' + IntToStr(Request.QueryFields.Count);
 for i := 0 to Request.QueryFields.Count - 1 do
 S := S + CR + 'QueryField: ' + Request.QueryFields.Strings[i];
 S := S + CR + 'Request.Referer: ' + Request.Referer;
 S := S + CR + 'Request.RemoteAddress: ' + Request.RemoteAddr;
 S := S + CR + 'Request.RemoteHost: ' + Request.RemoteHost;
 S := S + CR + 'Request.PathTranslated: ' + Request.PathTranslated;
 S := S + CR + 'Request.URL: ' + Request.URL;
 S := S + CR + 'Request.ScriptName: ' + Request.ScriptName;
 S := S + CR + 'Request.Title: ' + Request.Title;
 S := S + CR + 'Request.UserAgent: ' + Request.UserAgent;
 S := S + '';
 Result := S;
end;
*)
procedure DrawBitmap(PaintDC: HDC; Bitmap: HBitMap;
 XVal, Yval, AWidth, AHeight: Integer);
var
 MemDC: HDC;
 OldBitmap: HBitmap;
begin
 MemDC := CreateCompatibleDC(PaintDC);
 OldBitmap := SelectObject(MemDC, Bitmap);
 BitBlt(PaintDC, XVal, YVal, AWidth,
 AHeight, MemDC, 0, 0, SRCCOPY);
 SelectObject(MemDC, OldBitmap);
 DeleteObject(MemDC);
end;
{** BigFileSize returns the size of a file. The FileSize function returns
 an integer. This one works with large files. }
function BigFileSize(FileName: string): Int64;
var
 hFile: THandle;
 LoSize, HighSize: DWORD;
begin
 if Length(FileName) = 0 then Exit;
 hFile := CreateFile(PChar(FileName), GENERIC_READ,
 FILE_SHARE_READ, nil, OPEN_EXISTING,
 FILE_FLAG_SEQUENTIAL_SCAN, 0);
 if (hFile = 0) then Exit;
 LoSize := GetFileSize(hFile, @HighSize);
 Int64Rec(Result).Lo := LoSize;
 Int64Rec(Result).Hi := HighSize;
 CloseHandle(hFile);
end;
{**Check to see if a file has an extension in a list of extensions }
function CheckExtension(FileName: string; Values: array of string): Boolean;
var
 Ext, Value: string;
 i: Integer;
begin
 Result := True;
 Ext := ExtractFileExt(FileName);
 for i := 0 to High(Values) do begin
 Value := Values[i];
 if Value[1] <> '.' then
 Value := '.' + Value;
 if Value = Ext then Exit;
 end;
 Result := False;
end;
const
 SInvalidDest = 'Destination %s does not exist';
 SFCantMove = 'Cannot move file %s';
type
 EInvalidDest = class(EStreamError);
 EFCantMove = class(EStreamError);
{** Copy File From FmxUtils.pas in the Delphi 4 demos directory }
procedure EZCopyFile(const FileName, DestName: string);
var
 CopyBuffer: Pointer; { buffer for copying }
 BytesCopied: Longint;
 Source, Dest: Integer; { handles }
 Destination: TFileName; { holder for expanded destination name }
const
 ChunkSize: Longint = 8192; { copy in 8K chunks }
begin
 Destination := ExpandFileName(DestName); { expand the destination path }
 if HasAttr(Destination, faDirectory) then { if destination is a directory... }
 Destination := Destination + '\' + ExtractFileName(FileName); { ...clone file name }
 GetMem(CopyBuffer, ChunkSize); { allocate the buffer }
 try
 Source := FileOpen(FileName, fmShareDenyWrite); { open source file }
 if Source < 0 then raise EFOpenError.CreateFmt(SFOpenError, [FileName]);
 try
 Dest := FileCreate(Destination); { create output file; overwrite existing }
 if Dest < 0 then raise EFCreateError.CreateFmt(SFCreateError, [Destination]);
 try
 repeat
 BytesCopied := FileRead(Source, CopyBuffer^, ChunkSize); { read chunk }
 if BytesCopied > 0 then { if we read anything... }
 FileWrite(Dest, CopyBuffer^, BytesCopied); { ...write chunk }
 until BytesCopied < ChunkSize; { until we run out of chunks }
 finally
 FileClose(Dest); { close the destination file }
 end;
 finally
 FileClose(Source); { close the source file }
 end;
 finally
 FreeMem(CopyBuffer, ChunkSize); { free the buffer }
 end;
end;
{** MoveFile Moves the file passed in FileName to the directory specified in
 DestDir. Tries to just rename the file. If that fails, try to copy the file
 and delete the original. Raises an exception if the source file is read-only,
 and therefore cannot be deleted/moved.
 From FmxUtils.pas in the Delphi 4 demos directory } 
procedure MoveFile(const FileName, DestName: string);
var
 Destination: string;
begin
 Destination := ExpandFileName(DestName); { expand the destination path }
 if not RenameFile(FileName, Destination) then { try just renaming }
 begin
 if HasAttr(FileName, faReadOnly) then { if it's read-only... }
 raise EFCantMove.Create(Format(SFCantMove, [FileName])); { we wouldn't be able to delete it }
 EZCopyFile(FileName, Destination); { copy it over to destination...}
// DeleteFile(FileName); { ...and delete the original }
 end;
end;
{** GetFileSize returns the size of the named file without opening the file.
 If the file doesn't exist, returns -1.
 From FmxUtils.pas in the Delphi 4 demos directory }
function GetFileSize2(const FileName: string): LongInt;
var
 SearchRec: TSearchRec;
begin
 if FindFirst(ExpandFileName(FileName), faAnyFile, SearchRec) = 0 then
 Result := SearchRec.Size
 else Result := -1;
end;
{** FileDateTime
 From FmxUtils.pas in the Delphi 4 demos directory
}
function FileDateTime(const FileName: string): System.TDateTime;
begin
 Result := FileDateToDateTime(FileAge(FileName));
end;
{** HasAttr From FmxUtils.pas in the Delphi 4 demos directory }
function HasAttr(const FileName: string; Attr: Word): Boolean;
begin
 Result := (FileGetAttr(FileName) and Attr) = Attr;
end;
procedure GetNameAndExt(FileName: string; var Name: string; var Ext: string);
var
 FName: string;
begin
 FName := ExtractFileName(FileName);
 Ext := ExtractFileExt(FName);
 Name := StripLastToken(FName, '.');
end;
{** ExecuteFile From FmxUtils.pas in the Delphi 4 demos directory }
function ExecuteFile(const FileName, Params, DefaultDir: string;
 ShowCmd: Integer): THandle;
var
 zFileName, zParams, zDir: array[0..79] of Char;
begin
 Result := ShellExecute(Forms.Application.MainForm.Handle, nil,
 StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
 StrPCopy(zDir, DefaultDir), ShowCmd);
end;
function IsValidDir(S: string): Boolean;
var
 SaveDir: string;
begin
 SaveDir := GetCurrentDir;
 if SetCurrentDir(S) then
 Result := True
 else
 Result := False;
 SetCurrentDir(SaveDir);
end;
function IsPrinterOn(const Port : Word) : Boolean;
 const
 StRq : Byte = $02;
 var
 nRes : Byte;
begin
 asm
 MOV AH, StRq
 MOV DX, Port
 INT $17
 MOV nRes, AH
 end;
 Result := (nRes and $80) = $80;
end;
end.
Examples Delphi
