Mega Code Archive
Codebox
<![CDATA[
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:
<CODE>
SW_HIDE = 0;
SW_SHOWNORMAL = 1;
SW_SHOWMINIMIZED = 2;
SW_SHOWMAXIMIZED = 3;
</CODE>
@example
Here is an example:
<Code>
WinExec2('c:\windows\notepad.exe', ' c:\autoexec.bat', SW_SHOWNORMAL);
</Code> }
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
<Code>
WinExecAndWait('c:\windows\notepad.exe', '', SW_SHOWNORMAL);
ShowMessage('Call over');
</Code> }
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;
{**
<Code>
Name: ArcSin function
Declaration: function ArcSin(x: Real): Real;
Unit: MathBox
Code: N
Date: 02/20/94
Description: Find the ArcSin of a Real
</Code>}
function ArcSin(x: Real): Real;
begin
ArcSin := ArcTan(x / Sqrt( 1 - Sqr(x)));
end;
{** <Code>
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
</Code> }
function Comp2Str(N: Comp): String;
var
TempString: String;
begin
Str(N:0:0, TempString);
Comp2Str := TempString;
end;
{** <Code>
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.
</Code> }
function Int2Str(N: LongInt): String;
var
S : String;
begin
Str(N:0,S);
Int2Str := S;
end;
{** <Code>
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.
</Code> }
function Int2StrPad0(N: LongInt; Len: Integer): string;
begin
FmtStr(Result, '%d', [N]);
while Length(Result) < Len do
Result := '0' + Result;
end;
{** <Code>
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.
</Code> }
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;
{** <Code>
Name: LogXY function
Declaration: function LogXY(x: Real): Real;
Unit: MathBox
Code: N
Date: 02/20/94
Description: Log of X Y
</Code> }
function LogXY(x, y: Real): Real;
begin
LogXY := Ln(x) / Ln(y);
end;
{** <Code>
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
</Code> }
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;
{** <Code>
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
</Code> }
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 }
{** <Code>
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
</Code> }
function Real2Str(N: Real; Width, Places: integer): String;
var
TempString: String;
begin
Str(N:Width:Places, TempString);
Real2Str := TempString;
end;
{** <Code>
Name: Str2Comp function
Declaration: Str2Real(MyString: string)
Unit: MathBox
Code: N
Date: 02/17/94
Description: Converts a String to a Comp
</Code> }
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;
{** <Code>
Name: Str2Pennies function
Declaration: Str2Pennies(MyString: string)
Unit: MathBox
Code: N
Date: 02/17/94
Description: Converts a String to a Comp
</Code> }
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;
{** <Code>
Name: Str2Real function
Declaration: Str2Real(MyString: string)
Unit: MathBox
Code: N
Date: 02/17/94
Description: Converts a String to Real number
</Code> }
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;
{** <Code>
Name: XToTheY function
Declaration: XToTheY(x, y: Real): Real;
Unit: MathBox
Code: N
Date: 02/20/94
Description: Raise X to the Y Power
</Code> }
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 <jaggernout@geocities.com> 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;
{** <Code>
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
</Code> }
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;
{** <Code>
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
</Code> }
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;
{** <Code>
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.
</Code> }
{$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;
{** <Code>
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.
</Code> }
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;
{** <Code>
Name: GetTodaysDate function
Declaration: GetTodaysDate: string;
Unit: StrBox
Code: S
Date: 08/16/94
Description: Return a string of type MM/DD/YY.
</Code> }
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;
{** <Code>
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
</Code> }
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;
{** <Code>
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.
</Code> }
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;
{** <Code>
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';
</Code> }
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;
{** <Code>
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.
</Code> }
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;
{** <Code>
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.
</Code> }
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;
{** <Code>
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.
</Code> }
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;
{** <Code>
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
</Code> }
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;
{** <Code>
Name: OpenStorage
Declaration: OpenStorage(FileName: string);
Unit: Main
Description: Given a filename, try to open it as a storage
file.
</Code> }
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;
{** <Code>
Name: HandleProperty
Declaration:
Unit: Main
Description: Show Summary Info
</Code> }
procedure TSafeStore.HandleProperty(Storage: IStorage);
begin
{ Not Implemented }
end;
{** <Code>
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.
</Code> }
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;
{** <Code>
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.
</Code> }
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 = '<BR>';
var
i: Integer;
S: string;
begin
S := '<HTML><BODY>';
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 + '</BODY></HTML>';
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.
]]>