1733 lines
56 KiB
Plaintext
1733 lines
56 KiB
Plaintext
unit ORFn;
|
|
|
|
{$OPTIMIZATION OFF}
|
|
|
|
interface // --------------------------------------------------------------------------------
|
|
|
|
uses SysUtils, Windows, Messages, Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Forms,
|
|
Graphics, Menus, RichEdit;
|
|
|
|
const
|
|
U = '^';
|
|
CRLF = #13#10;
|
|
BOOLCHAR: array[Boolean] of Char = ('0', '1');
|
|
UM_STATUSTEXT = (WM_USER + 302); // used to send update status msg to main form
|
|
COLOR_CREAM = $F0FBFF;
|
|
|
|
type
|
|
TFMDateTime = Double;
|
|
TORIdleCallProc = procedure(Msg: string);
|
|
|
|
{ Date/Time functions }
|
|
function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
|
|
function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
|
|
function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
|
|
function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
|
|
function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
|
|
function IsFMDateTime(x: string): Boolean;
|
|
function MakeFMDateTime(const AString: string): TFMDateTime;
|
|
procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
|
|
PieceNum: Integer; KeepBad: boolean = FALSE);
|
|
|
|
{ Numeric functions }
|
|
function HigherOf(i, j: Integer): Integer;
|
|
function LowerOf(i, j: Integer): Integer;
|
|
function StrToFloatDef(const S: string; ADefault: Extended): Extended;
|
|
|
|
{ String functions }
|
|
function CharAt(const x: string; APos: Integer): Char;
|
|
function ContainsAlpha(const x: string): Boolean;
|
|
function ContainsVisibleChar(const x: string): Boolean;
|
|
function ConvertSpecialStrings(const x: string): String;
|
|
function CRCForFile(AFileName: string): DWORD;
|
|
function CRCForStrings(AStringList: TStrings): DWORD;
|
|
procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
|
|
function ExtractInteger(x: string): Integer;
|
|
function ExtractFloat(x: string): Extended;
|
|
function ExtractDefault(Src: TStrings; const Section: string): string;
|
|
procedure ExtractItems(Dest, Src: TStrings; const Section: string);
|
|
procedure ExtractText(Dest, Src: TStrings; const Section: string);
|
|
function FilteredString(const x: string; ATabWidth: Integer = 8): string;
|
|
procedure InvertStringList(AList: TStringList);
|
|
procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
|
|
function MixedCase(const x: string): string;
|
|
procedure MixedCaseList(AList: TStrings);
|
|
procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
|
|
function Piece(const S: string; Delim: char; PieceNum: Integer): string;
|
|
function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
|
|
function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
|
|
char = '^'; CaseInsensitive: boolean = FALSE): integer;
|
|
procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
|
|
function ReverseStr(const x: string): string;
|
|
procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
|
|
procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
|
|
FromString: string);
|
|
procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
|
|
function DelimCount(const Str, Delim: string): integer;
|
|
procedure QuickCopy(AFrom, ATo: TObject);
|
|
function ValidFileName(const InitialFileName: string): string;
|
|
|
|
{ Display functions }
|
|
procedure ForceInsideWorkArea( var Rect: TRect);
|
|
//procedure ClearControl(AControl: TControl);
|
|
function InfoBox(const Text, Caption: string; Flags: Word): Integer;
|
|
procedure LimitEditWidth(AControl: TWinControl; NumChars: Integer);
|
|
function MainFont: TFont;
|
|
function MainFontSize: Integer;
|
|
function MainFontWidth: Integer;
|
|
function MainFontHeight: Integer;
|
|
function BaseFont: TFont;
|
|
procedure RedrawSuspend(AHandle: HWnd);
|
|
procedure RedrawActivate(AHandle: HWnd);
|
|
//procedure ResetControl(AControl: TControl);
|
|
procedure ResetSelectedForList(AListBox: TListBox);
|
|
procedure ResizeFormToFont(AForm: TForm);
|
|
procedure ResizeAnchoredFormToFont( AForm: TForm);
|
|
function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
|
|
function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
|
|
procedure ResizeToFont(FontSize: Integer; var W, H: Integer);
|
|
procedure SetEqualTabStops(AControl: TControl; TabWidth: Integer = 8);
|
|
procedure StatusText(const S: string);
|
|
function ShowMsgOn(AnExpression: Boolean; const AMsg, ACaption: string): Boolean;
|
|
function TextWidthByFont(AFontHandle: THandle; const x: string): Integer;
|
|
function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
|
|
function WrappedTextHeightByFont(Canvas: TCanvas; NewFont: TFont; ItemText: string; var ARect: TRect): integer;
|
|
function NumCharsFitInWidth(AFontHandle: THandle; const x: string; const MaxLen: integer): Integer;
|
|
function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
|
|
procedure ReformatMemoParagraph(AMemo: TCustomMemo);
|
|
function ReadOnlyColor: TColor;
|
|
|
|
{ ListBox Grid functions }
|
|
procedure ListGridDrawCell(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
|
const x: string; WordWrap: Boolean);
|
|
procedure ListGridDrawLines(AListBox: TListBox; AHeader: THeaderControl; Index: Integer;
|
|
State: TOwnerDrawState);
|
|
function ListGridRowHeight(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
|
const x: string): Integer;
|
|
|
|
{ Misc functions }
|
|
{ You MUST pass an address to an object variable to get KillObj to work }
|
|
procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
|
|
|
|
{ do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet }
|
|
procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
|
|
procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
|
|
procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
|
|
function TabIsPressed : Boolean;
|
|
function ShiftTabIsPressed : Boolean;
|
|
|
|
implementation // ---------------------------------------------------------------------------
|
|
|
|
uses
|
|
ORCtrls, Grids, Chart, CheckLst;
|
|
|
|
const
|
|
{ names of months used by FormatFMDateTime }
|
|
MONTH_NAMES_SHORT: array[1..12] of string[3] =
|
|
('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
|
|
MONTH_NAMES_LONG: array[1..12] of string[9] =
|
|
('January','February','March','April','May','June','July','August','September','October',
|
|
'November', 'December');
|
|
|
|
// ConvertSpecialStrings arrays
|
|
SearchChars: array[0..7] of String = (' Ii ',' Iii ',' Iv ',' Vi ',' Vii ',' Viii ',' Ix ','-Va');
|
|
ReplaceChars: array[0..7] of String = (' II ',' III ',' IV ',' VI ',' VII ',' VIII ',' IX ','-VA');
|
|
|
|
{ table for calculating CRC values (DWORD is Integer in Delphi 3, Cardinal in Delphi 4}
|
|
CRC32_TABLE: array[0..255] of DWORD =
|
|
($0, $77073096, $EE0E612C, $990951BA, $76DC419, $706AF48F, $E963A535, $9E6495A3,
|
|
$EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $9B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
|
|
$1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
|
|
$136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
|
|
$3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
|
|
$35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
|
|
$26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
|
|
$2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
|
|
$76DC4190, $1DB7106, $98D220BC, $EFD5102A, $71B18589, $6B6B51F, $9FBFE4A5, $E8B8D433,
|
|
$7807C9A2, $F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $86D3D2D, $91646C97, $E6635C01,
|
|
$6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
|
|
$65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
|
|
$4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
|
|
$4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
|
|
$5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
|
|
$5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
|
|
$EDB88320, $9ABFB3B6, $3B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $4DB2615, $73DC1683,
|
|
$E3630B12, $94643B84, $D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $A00AE27, $7D079EB1,
|
|
$F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
|
|
$FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
|
|
$D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
|
|
$D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
|
|
$CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
|
|
$C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
|
|
$9B64C2B0, $EC63F226, $756AA39C, $26D930A, $9C0906A9, $EB0E363F, $72076785, $5005713,
|
|
$95BF4A82, $E2B87A14, $7BB12BAE, $CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $BDBDF21,
|
|
$86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
|
|
$88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
|
|
$A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
|
|
$AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
|
|
$BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
|
|
$B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
|
|
|
|
{Properties assigned to BaseFont}
|
|
BaseFontSize = 8;
|
|
BaseFontName = 'MS Sans Serif';
|
|
var
|
|
FBaseFont: TFont;
|
|
type
|
|
EFMDateTimeError = class(Exception);
|
|
|
|
{TFontControl is an artifact used for font resizing. Do not add virtual
|
|
methods or class variables to it!}
|
|
TFontControl = class(TControl)
|
|
public
|
|
property Font;
|
|
property ParentFont;
|
|
end;
|
|
|
|
{ Date/Time functions }
|
|
|
|
function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
|
|
{ converts a Delphi date/time type to a Fileman date/time (type double) }
|
|
var
|
|
y, m, d, h, n, s, l: Word;
|
|
DatePart,TimePart: Integer;
|
|
begin
|
|
DecodeDate(ADateTime, y, m, d);
|
|
DecodeTime(ADateTime, h, n, s, l);
|
|
DatePart := ((y-1700)*10000) + (m*100) + d;
|
|
TimePart := (h*10000) + (n*100) + s;
|
|
Result := DatePart + (TimePart / 1000000);
|
|
end;
|
|
|
|
function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
|
|
{ converts a Fileman date/time (type double) to a Delphi date/time }
|
|
var
|
|
ADate, ATime: TDateTime;
|
|
DatePart, TimePart: string;
|
|
begin
|
|
DatePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 1);
|
|
TimePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 2) + '000000';
|
|
if Length(DatePart) <> 7 then raise EFMDateTimeError.Create('Invalid Fileman Date');
|
|
if Copy(TimePart, 1, 2) = '24' then TimePart := '23595959';
|
|
ADate := EncodeDate(StrToInt(Copy(DatePart, 1, 3)) + 1700,
|
|
StrToInt(Copy(DatePart, 4, 2)),
|
|
StrToInt(Copy(DatePart, 6, 2)));
|
|
ATime := EncodeTime(StrToInt(Copy(TimePart, 1, 2)),
|
|
StrToInt(Copy(TimePart, 3, 2)),
|
|
StrToInt(Copy(TimePart, 5, 2)), 0);
|
|
Result := ADate + ATime;
|
|
end;
|
|
|
|
function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
|
|
{ adds / subtracts days from a Fileman date/time and returns the offset Fileman date/time }
|
|
var
|
|
Julian: TDateTime;
|
|
begin
|
|
Julian := FMDateTimeToDateTime(ADateTime);
|
|
Result := DateTimeToFMDateTime(Julian + DaysDiff);
|
|
end;
|
|
|
|
function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
|
|
{ formats a Fileman Date/Time using (mostly) the same format string as Delphi FormatDateTime }
|
|
var
|
|
x: string;
|
|
y, m, d, h, n, s: Integer;
|
|
|
|
function TrimFormatCount: Integer;
|
|
{ delete repeating characters and count how many were deleted }
|
|
var
|
|
c: Char;
|
|
begin
|
|
Result := 0;
|
|
c := AFormat[1];
|
|
repeat
|
|
Delete(AFormat, 1, 1);
|
|
Inc(Result);
|
|
until CharAt(AFormat, 1) <> c;
|
|
end;
|
|
|
|
begin {FormatFMDateTime}
|
|
Result := '';
|
|
if not (ADateTime > 0) then Exit;
|
|
x := FloatToStrF(ADateTime, ffFixed, 15, 6) + '0000000';
|
|
y := StrToIntDef(Copy(x, 1, 3), 0) + 1700;
|
|
m := StrToIntDef(Copy(x, 4, 2), 0);
|
|
d := StrToIntDef(Copy(x, 6, 2), 0);
|
|
h := StrToIntDef(Copy(x, 9, 2), 0);
|
|
n := StrToIntDef(Copy(x, 11, 2), 0);
|
|
s := StrToIntDef(Copy(x, 13, 2), 0);
|
|
while Length(AFormat) > 0 do
|
|
case UpCase(AFormat[1]) of
|
|
'"': begin // literal
|
|
Delete(AFormat, 1, 1);
|
|
while not (CharAt(AFormat, 1) in [#0, '"']) do
|
|
begin
|
|
Result := Result + AFormat[1];
|
|
Delete(AFormat, 1, 1);
|
|
end;
|
|
if CharAt(AFormat, 1) = '"' then Delete(AFormat, 1, 1);
|
|
end;
|
|
'D': case TrimFormatCount of // day/date
|
|
1: if d > 0 then Result := Result + IntToStr(d);
|
|
2: if d > 0 then Result := Result + FormatFloat('00', d);
|
|
end;
|
|
'H': case TrimFormatCount of // hour
|
|
1: Result := Result + IntToStr(h);
|
|
2: Result := Result + FormatFloat('00', h);
|
|
end;
|
|
'M': case TrimFormatCount of // month
|
|
1: if m > 0 then Result := Result + IntToStr(m);
|
|
2: if m > 0 then Result := Result + FormatFloat('00', m);
|
|
3: if m in [1..12] then Result := Result + MONTH_NAMES_SHORT[m];
|
|
4: if m in [1..12] then Result := Result + MONTH_NAMES_LONG[m];
|
|
end;
|
|
'N': case TrimFormatCount of // minute
|
|
1: Result := Result + IntToStr(n);
|
|
2: Result := Result + FormatFloat('00', n);
|
|
end;
|
|
'S': case TrimFormatCount of // second
|
|
1: Result := Result + IntToStr(s);
|
|
2: Result := Result + FormatFloat('00', s);
|
|
end;
|
|
'Y': case TrimFormatCount of // year
|
|
2: if y > 0 then Result := Result + Copy(IntToStr(y), 3, 2);
|
|
4: if y > 0 then Result := Result + IntToStr(y);
|
|
end;
|
|
else begin // other
|
|
Result := Result + AFormat[1];
|
|
Delete(AFormat, 1, 1);
|
|
end;
|
|
end; {case}
|
|
end; {FormatFMDateTime}
|
|
|
|
function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
|
|
var
|
|
FMDateTime: TFMDateTime;
|
|
begin
|
|
Result := ADateTime;
|
|
if IsFMDateTime(ADateTime) then
|
|
begin
|
|
FMDateTime := MakeFMDateTime(ADateTime);
|
|
Result := FormatFMDateTime(AFormat, FMDateTime);
|
|
end;
|
|
end;
|
|
|
|
function IsFMDateTime(x: string): Boolean;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
if Length(x) < 7 then Exit;
|
|
for i := 1 to 7 do if not (x[i] in ['0'..'9']) then Exit;
|
|
if (Length(x) > 7) and (x[8] <> '.') then Exit;
|
|
if (Length(x) > 8) and not (x[9] in ['0'..'9']) then Exit;
|
|
Result := True;
|
|
end;
|
|
|
|
function MakeFMDateTime(const AString: string): TFMDateTime;
|
|
begin
|
|
Result := -1;
|
|
if (Length(AString) > 0) and IsFMDateTime(AString) then Result := StrToFloat(AString);
|
|
end;
|
|
|
|
procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
|
|
PieceNum: Integer; KeepBad: boolean = FALSE);
|
|
var
|
|
i: Integer;
|
|
s, x, x1: string;
|
|
|
|
begin
|
|
for i := 0 to AList.Count - 1 do
|
|
begin
|
|
s := AList[i];
|
|
x := Piece(s, ADelim, PieceNum);
|
|
if Length(x) > 0 then
|
|
begin
|
|
x1 := FormatFMDateTime(AFormat, MakeFMDateTime(x));
|
|
if(x1 <> '') or (not KeepBad) then
|
|
x := x1;
|
|
end;
|
|
SetPiece(s, ADelim, PieceNum, x);
|
|
AList[i] := s;
|
|
end;
|
|
end;
|
|
|
|
{ Numeric functions }
|
|
|
|
function HigherOf(i, j: Integer): Integer;
|
|
{ returns the greater of two integers }
|
|
begin
|
|
Result := i;
|
|
if j > i then Result := j;
|
|
end;
|
|
|
|
function LowerOf(i, j: Integer): Integer;
|
|
{ returns the lesser of two integers }
|
|
begin
|
|
Result := i;
|
|
if j < i then Result := j;
|
|
end;
|
|
|
|
function StrToFloatDef(const S: string; ADefault: Extended): Extended;
|
|
begin
|
|
if not TextToFloat(PChar(S), Result, fvExtended) then
|
|
Result := ADefault;
|
|
end;
|
|
|
|
{ String functions }
|
|
|
|
function CharAt(const x: string; APos: Integer): Char;
|
|
{ returns a character at a given position in a string or the null character if past the end }
|
|
begin
|
|
if Length(x) < APos then Result := #0 else Result := x[APos];
|
|
end;
|
|
|
|
function ContainsAlpha(const x: string): Boolean;
|
|
{ returns true if the string contains any alpha characters }
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
for i := 1 to Length(x) do if x[i] in ['A'..'Z','a'..'z'] then
|
|
begin
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function ContainsVisibleChar(const x: string): Boolean;
|
|
{ returns true if the string contains any printable characters }
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := False;
|
|
for i := 1 to Length(x) do if x[i] in ['!'..'~'] then // ordinal values 33..126
|
|
begin
|
|
Result := True;
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
function ConvertSpecialStrings(const x: string): string;
|
|
var i : Integer;
|
|
begin
|
|
for i := 0 to Length(SearchChars)-1 do
|
|
begin
|
|
Result := StringReplace(Result,SearchChars[i], ReplaceChars[i],[rfReplaceAll]);
|
|
end;
|
|
end;
|
|
|
|
function UpdateCrc32(Value: DWORD; var Buffer: array of Byte; Count: Integer): DWORD;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Result:=Value;
|
|
for i := 0 to Pred(Count) do
|
|
Result := ((Result shr 8) and $00FFFFFF) xor
|
|
CRC32_TABLE[(Result xor Buffer[i]) and $000000FF];
|
|
end;
|
|
|
|
function CRCForFile(AFileName: string): DWORD;
|
|
const
|
|
BUF_SIZE = 16383;
|
|
type
|
|
TBuffer = array[0..BUF_SIZE] of Byte;
|
|
var
|
|
Buffer: Pointer;
|
|
AHandle, BytesRead: Integer;
|
|
begin
|
|
Result:=$FFFFFFFF;
|
|
GetMem(Buffer, BUF_SIZE);
|
|
AHandle := FileOpen(AFileName, fmShareDenyWrite);
|
|
repeat
|
|
BytesRead := FileRead(AHandle, Buffer^, BUF_SIZE);
|
|
Result := UpdateCrc32(Result, TBuffer(Buffer^), BytesRead);
|
|
until BytesRead <> BUF_SIZE;
|
|
FileClose(AHandle);
|
|
FreeMem(Buffer);
|
|
Result := not Result;
|
|
end;
|
|
|
|
function CRCForStrings(AStringList: TStrings): DWORD;
|
|
{ returns a cyclic redundancy check for a list of strings }
|
|
var
|
|
i, j: Integer;
|
|
begin
|
|
Result:=$FFFFFFFF;
|
|
for i := 0 to AStringList.Count - 1 do
|
|
for j := 1 to Length(AStringList[i]) do
|
|
Result:=((Result shr 8) and $00FFFFFF) xor
|
|
CRC32_TABLE[(Result xor Ord(AStringList[i][j])) and $000000FF];
|
|
end;
|
|
|
|
function FilteredString(const x: string; ATabWidth: Integer = 8): string;
|
|
var
|
|
i, j: Integer;
|
|
begin
|
|
Result := '';
|
|
for i := 1 to Length(x) do
|
|
case x[i] of
|
|
#9: for j := 1 to (ATabWidth - (Length(Result) mod ATabWidth)) do
|
|
Result := Result + ' ';
|
|
#32..#127: Result := Result + x[i];
|
|
#128..#159: Result := Result + '?';
|
|
#10,#13,#160: Result := Result + ' ';
|
|
#161..#255: Result := Result + x[i];
|
|
end;
|
|
if Copy(Result, Length(Result), 1) = ' ' then Result := TrimRight(Result) + ' ';
|
|
end;
|
|
|
|
procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
|
|
var
|
|
i, j, k: Integer;
|
|
x, y: string;
|
|
begin
|
|
with AList do for i := 0 to Count - 1 do
|
|
begin
|
|
x := Strings[i];
|
|
y := '';
|
|
for j := 1 to Length(x) do
|
|
case x[j] of
|
|
#9: for k := 1 to (ATabWidth - (Length(y) mod ATabWidth)) do y := y + ' ';
|
|
#32..#127: y := y + x[j];
|
|
#128..#159: y := y + '?';
|
|
#160: y := y + ' ';
|
|
#161..#255: y := y + x[j];
|
|
end;
|
|
if Copy(y, Length(y), 1) = ' ' then y := TrimRight(y) + ' ';
|
|
Strings[i] := y;
|
|
//Strings[i] := TrimRight(y) + ' ';
|
|
end;
|
|
end;
|
|
|
|
function ExtractInteger(x: string): Integer;
|
|
{ strips leading & trailing alphas to return an integer }
|
|
var
|
|
i: Integer;
|
|
begin
|
|
while (Length(x) > 0) and not (x[1] in ['0'..'9']) do Delete(x, 1, 1);
|
|
for i := 1 to Length(x) do if not (x[i] in ['0'..'9']) then break;
|
|
Result := StrToIntDef(Copy(x, 1, i - 1), 0);
|
|
end;
|
|
|
|
function ExtractFloat(x: string): Extended;
|
|
{ strips leading & trailing alphas to return a float }
|
|
var
|
|
i: Integer;
|
|
begin
|
|
while (Length(x) > 0) and not (x[1] in ['0'..'9', '.']) do Delete(x, 1, 1);
|
|
for i := 1 to Length(x) do if not (x[i] in ['0'..'9','.']) then break;
|
|
Result := StrToFloatDef(Copy(x, 1, i - 1), 0);
|
|
end;
|
|
|
|
function ExtractDefault(Src: TStrings; const Section: string): string;
|
|
var
|
|
i: Integer;
|
|
begin
|
|
Result := '';
|
|
i := -1;
|
|
repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
|
|
Inc(i);
|
|
if (i < Src.Count) and (Src[i][1] <> '~') then repeat
|
|
if Src[i][1] = 'd' then Result := Copy(Src[i], 2, MaxInt);
|
|
Inc(i);
|
|
until (i = Src.Count) or (Src[i][1] = '~') or (Length(Result) > 0);
|
|
end;
|
|
|
|
procedure ExtractItems(Dest, Src: TStrings; const Section: string);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := -1;
|
|
repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
|
|
Inc(i);
|
|
if (i < Src.Count) and (Src[i][1] <> '~') then repeat
|
|
if Src[i][1] = 'i' then Dest.Add(Copy(Src[i], 2, MaxInt));
|
|
Inc(i);
|
|
until (i = Src.Count) or (Src[i][1] = '~');
|
|
end;
|
|
|
|
procedure ExtractText(Dest, Src: TStrings; const Section: string);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
i := -1;
|
|
repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
|
|
Inc(i);
|
|
if (i < Src.Count) and (Src[i][1] <> '~') then repeat
|
|
if Src[i][1] = 't' then Dest.Add(Copy(Src[i], 2, MaxInt));
|
|
Inc(i);
|
|
until (i = Src.Count) or (Src[i][1] = '~');
|
|
end;
|
|
|
|
procedure InvertStringList(AList: TStringList);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
with AList do for i := 0 to ((Count div 2) - 1) do Exchange(i, Count - i - 1);
|
|
end;
|
|
|
|
function MixedCase(const x: string): string;
|
|
var
|
|
i: integer;
|
|
begin
|
|
Result := x;
|
|
for i := 2 to Length(x) do
|
|
if (not (x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
|
|
// save line if (not (x[i-1] in [' ','''',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
|
|
then Result[i] := Chr(Ord(x[i]) + 32)
|
|
else if ((x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['a'..'z'])
|
|
then Result[i] := Chr(Ord(x[i]) - 32);
|
|
//Call added to satisfy the need for special string handling(Roman Numerals II-XI) GRE-06/02
|
|
Result := ConvertSpecialStrings(x);
|
|
end;
|
|
|
|
procedure MixedCaseList(AList: TStrings);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to (AList.Count - 1) do AList[i] := MixedCase(AList[i]);
|
|
end;
|
|
|
|
procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
|
|
var
|
|
i: Integer;
|
|
x, p: string;
|
|
begin
|
|
for i := 0 to (AList.Count - 1) do
|
|
begin
|
|
x := AList[i];
|
|
p := MixedCase(Piece(x, ADelim, PieceNum));
|
|
SetPiece(x, ADelim, PieceNum, p);
|
|
AList[i] := x;
|
|
end;
|
|
end;
|
|
|
|
function Piece(const S: string; Delim: char; PieceNum: Integer): string;
|
|
{ returns the Nth piece (PieceNum) of a string delimited by Delim }
|
|
var
|
|
i: Integer;
|
|
Strt, Next: PChar;
|
|
begin
|
|
i := 1;
|
|
Strt := PChar(S);
|
|
Next := StrScan(Strt, Delim);
|
|
while (i < PieceNum) and (Next <> nil) do
|
|
begin
|
|
Inc(i);
|
|
Strt := Next + 1;
|
|
Next := StrScan(Strt, Delim);
|
|
end;
|
|
if Next = nil then Next := StrEnd(Strt);
|
|
if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
|
|
end;
|
|
|
|
function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
|
|
{ returns several contiguous pieces }
|
|
var
|
|
PieceNum: Integer;
|
|
begin
|
|
Result := '';
|
|
for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
|
|
if Length(Result) > 0 then Delete(Result, Length(Result), 1);
|
|
end;
|
|
|
|
function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
|
|
char = '^'; CaseInsensitive: boolean = FALSE): integer;
|
|
var
|
|
i: integer;
|
|
|
|
begin
|
|
i := 0;
|
|
Result := 0;
|
|
while i <= high(Pieces) do
|
|
begin
|
|
if(CaseInsensitive) then
|
|
Result := CompareText(Piece(P1, Delim, Pieces[i]),
|
|
Piece(P2, Delim, Pieces[i]))
|
|
else
|
|
Result := CompareStr(Piece(P1, Delim, Pieces[i]),
|
|
Piece(P2, Delim, Pieces[i]));
|
|
if(Result = 0) then
|
|
inc(i)
|
|
else
|
|
break;
|
|
end;
|
|
end;
|
|
|
|
procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
|
|
{ adds each piece to a TStrings list, the list is cleared first }
|
|
var
|
|
APiece: string;
|
|
begin
|
|
AList.Clear;
|
|
while Length(x) > 0 do
|
|
begin
|
|
APiece := Piece(x, ADelim, 1);
|
|
AList.Add(APiece);
|
|
Delete(x, 1, Length(APiece) + 1);
|
|
end;
|
|
end;
|
|
|
|
function ReverseStr(const x: string): string;
|
|
var
|
|
i, j: Integer;
|
|
begin
|
|
SetString(Result, PChar(x), Length(x));
|
|
i := 0;
|
|
for j := Length(x) downto 1 do
|
|
begin
|
|
Inc(i);
|
|
Result[i] := x[j];
|
|
end;
|
|
end;
|
|
|
|
procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
|
|
{ sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
|
|
var
|
|
i: Integer;
|
|
Strt, Next: PChar;
|
|
begin
|
|
i := 1;
|
|
Strt := PChar(x);
|
|
Next := StrScan(Strt, Delim);
|
|
while (i < PieceNum) and (Next <> nil) do
|
|
begin
|
|
Inc(i);
|
|
Strt := Next + 1;
|
|
Next := StrScan(Strt, Delim);
|
|
end;
|
|
if Next = nil then Next := StrEnd(Strt);
|
|
if i < PieceNum
|
|
then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece
|
|
else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next);
|
|
end;
|
|
|
|
procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
|
|
FromString: string);
|
|
var
|
|
i: integer;
|
|
|
|
begin
|
|
for i := low(Pieces) to high(Pieces) do
|
|
SetPiece(x, Delim, Pieces[i], Piece(FromString, Delim, Pieces[i]));
|
|
end;
|
|
|
|
procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to AList.Count - 1 do
|
|
AList[i] := Piece(AList[i], ADelim, PieceNum) + ADelim + AList[i];
|
|
AList.Sort;
|
|
for i := 0 to AList.Count - 1 do
|
|
AList[i] := Copy(AList[i], Pos(ADelim, AList[i]) + 1, MaxInt);
|
|
end;
|
|
|
|
function DelimCount(const Str, Delim: string): integer;
|
|
var
|
|
i, dlen, slen: integer;
|
|
|
|
begin
|
|
Result := 0;
|
|
i := 1;
|
|
dlen := length(Delim);
|
|
slen := length(Str) - dlen + 1;
|
|
while(i <= slen) do
|
|
begin
|
|
if(copy(Str,i,dlen) = Delim) then
|
|
begin
|
|
inc(Result);
|
|
inc(i,dlen);
|
|
end
|
|
else
|
|
inc(i);
|
|
end;
|
|
end;
|
|
|
|
type
|
|
TREStrings = class(TStrings)
|
|
protected
|
|
FPlainText: Boolean;
|
|
public
|
|
property PlainText: Boolean read FPlainText write FPlainText;
|
|
end;
|
|
|
|
type
|
|
QuickCopyError = class(Exception);
|
|
|
|
procedure QuickCopy(AFrom, ATo: TObject);
|
|
var
|
|
ms: TMemoryStream;
|
|
idx: integer;
|
|
str: array[0..1] of TStrings;
|
|
fix: array[0..1] of boolean;
|
|
|
|
procedure GetStrings(obj: TObject);
|
|
begin
|
|
if (CompareText(obj.ClassName, 'TRichEditStrings') = 0) then
|
|
raise QuickCopyError.Create('You must pass the TRichEdit object into QuickCopy, NOT it''s Lines property.');
|
|
if obj is TStrings then
|
|
str[idx] := TStrings(obj)
|
|
else
|
|
if obj is TMemo then
|
|
str[idx] := TMemo(obj).Lines
|
|
else
|
|
if obj is TORListBox then
|
|
str[idx] := TORListBox(obj).Items
|
|
else
|
|
if obj is TListBox then
|
|
str[idx] := TListBox(obj).Items
|
|
else
|
|
if obj is TRichEdit then
|
|
begin
|
|
with TRichEdit(obj) do
|
|
begin
|
|
str[idx] := Lines;
|
|
if not PlainText then
|
|
begin
|
|
fix[idx] := TRUE;
|
|
PlainText := TRUE;
|
|
end;
|
|
end;
|
|
end
|
|
else
|
|
raise QuickCopyError.Create('Unsupported object type (' + obj.ClassName +
|
|
') passed into QuickCopy.');
|
|
inc(idx);
|
|
end;
|
|
|
|
|
|
begin
|
|
fix[0] := FALSE;
|
|
fix[1] := FALSE;
|
|
idx := 0;
|
|
GetStrings(AFrom);
|
|
GetStrings(ATo);
|
|
ms := TMemoryStream.Create;
|
|
try
|
|
str[0].SaveToStream(ms);
|
|
ms.Seek(0, soFromBeginning);
|
|
str[1].LoadFromStream(ms);
|
|
finally
|
|
ms.Free;
|
|
end;
|
|
if fix[0] then TRichEdit(AFrom).PlainText := FALSE;
|
|
if fix[1] then TRichEdit(ATo).PlainText := FALSE;
|
|
end;
|
|
|
|
function ValidFileName(const InitialFileName: string): string;
|
|
var
|
|
i: integer;
|
|
|
|
begin
|
|
Result := InitialFileName;
|
|
i := 1;
|
|
while i <= length(Result) do
|
|
begin
|
|
if Result[i] in ['a'..'z','A'..'Z','0'..'9',#32] then
|
|
inc(i)
|
|
else
|
|
delete(Result,i,1);
|
|
end;
|
|
end;
|
|
|
|
procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
|
|
var
|
|
i, SpacePos: Integer;
|
|
x: string;
|
|
NewList: TStringList;
|
|
begin
|
|
NewList := TStringList.Create;
|
|
try
|
|
for i := 0 to AList.Count - 1 do
|
|
begin
|
|
if Length(AList[i]) > MaxLength then
|
|
begin
|
|
x := AList[i];
|
|
while Length(x) > MaxLength do
|
|
begin
|
|
SpacePos := MaxLength;
|
|
// while SpacePos > 0 do {**REV**} removed after v11b
|
|
// if (x[SpacePos] <> ' ') then Dec(SpacePos); {**REV**} removed after v11b
|
|
while (x[SpacePos] <> ' ') and (SpacePos > 1) do Dec(SpacePos); {**REV**} {changed 0 to 1}
|
|
if SpacePos = 1 then SpacePos := MaxLength; {**REV**} {changed 0 to 1}
|
|
NewList.Add(Copy(x, 1, SpacePos )); // CQ PSI-05-040 change SpacePos-1 to SpacePos
|
|
Delete(x, 1, SpacePos);
|
|
end; {while Length(x)}
|
|
if Length(x) > 0 then NewList.Add(x);
|
|
end {then}
|
|
else NewList.Add(AList[i]);
|
|
end; {for i}
|
|
AList.Clear;
|
|
AList.Assign(NewList);
|
|
finally
|
|
NewList.Free;
|
|
end;
|
|
end;
|
|
|
|
{ Display functions }
|
|
|
|
(*
|
|
procedure ClearControl(AControl: TControl);
|
|
{ clears a control, removes text and listbox items }
|
|
begin
|
|
if AControl is TLabel then with TLabel(AControl) do Caption := ''
|
|
else if AControl is TButton then with TButton(AControl) do Caption := ''
|
|
else if AControl is TEdit then with TEdit(AControl) do Text := ''
|
|
else if AControl is TMemo then with TMemo(AControl) do Clear
|
|
else if AControl is TListBox then with TListBox(AControl) do Clear
|
|
else if AControl is TORComboBox then with TORComboBox(AControl) do
|
|
begin
|
|
MItems.Clear;
|
|
Text := '';
|
|
end
|
|
else if AControl is TComboBox then with TComboBox(AControl) do
|
|
begin
|
|
Clear;
|
|
Text := '';
|
|
end;
|
|
end;
|
|
|
|
procedure ResetControl(AControl: TControl);
|
|
{ clears text, deselects items, does not remove listbox or combobox items }
|
|
begin
|
|
if AControl is TLabel then with TLabel(AControl) do Caption := ''
|
|
else if AControl is TButton then with TButton(AControl) do Caption := ''
|
|
else if AControl is TEdit then with TEdit(AControl) do Text := ''
|
|
else if AControl is TMemo then with TMemo(AControl) do Clear
|
|
else if AControl is TListBox then with TListBox(AControl) do ItemIndex := -1
|
|
else if AControl is TORComboBox then with TORComboBox(AControl) do
|
|
begin
|
|
Text := '';
|
|
ItemIndex := -1;
|
|
end
|
|
else if AControl is TComboBox then with TComboBox(AControl) do
|
|
begin
|
|
Text := '';
|
|
ItemIndex := -1;
|
|
end;
|
|
end;
|
|
*)
|
|
|
|
function InfoBox(const Text, Caption: string; Flags: Word): Integer;
|
|
{ wrap the messagebox object in case we want to modify it later }
|
|
begin
|
|
Result := Application.MessageBox(PChar(Text), PChar(Caption), Flags or MB_TOPMOST);
|
|
end;
|
|
|
|
procedure LimitEditWidth(AControl: TWinControl; NumChars: Integer);
|
|
{ limits the editing area to be no more than N characters (also sets small left margin) }
|
|
const
|
|
LEFT_MARGIN = 4;
|
|
var
|
|
ARect: TRect;
|
|
AHandle: DWORD;
|
|
AWidth, i: Integer;
|
|
x: string;
|
|
begin
|
|
Inc(NumChars);
|
|
SetString(x, nil, NumChars);
|
|
for i := 1 to NumChars do x[i] := 'X';
|
|
with AControl do
|
|
begin
|
|
AHandle := 0;
|
|
if AControl is TEdit then AHandle := TEdit(AControl).Font.Handle;
|
|
if AControl is TMemo then AHandle := TMemo(AControl).Font.Handle;
|
|
if AControl is TRichEdit then AHandle := TRichEdit(AControl).Font.Handle;
|
|
if AHandle = 0 then Exit;
|
|
AWidth := TextWidthByFont(AHandle, x);
|
|
ARect := Rect(LEFT_MARGIN, 0, AWidth + LEFT_MARGIN, ClientHeight);
|
|
// set the editing rectangle to with with of NumChars
|
|
SendMessage(Handle, EM_SETRECT, 0, Longint(@ARect));
|
|
// turn on auto-scrolling for a rich edit
|
|
if AControl is TRichEdit
|
|
then SendMessage(Handle, EM_SETOPTIONS, ECOOP_OR, ECO_AUTOHSCROLL + ECO_AUTOVSCROLL);
|
|
end;
|
|
end;
|
|
|
|
function BaseFont: TFont;
|
|
begin
|
|
result := FBaseFont;
|
|
end;
|
|
|
|
function MainFont: TFont;
|
|
begin
|
|
if Application.MainForm <> nil
|
|
then Result := Application.MainForm.Font
|
|
else Result := BaseFont;
|
|
end;
|
|
|
|
function MainFontSize: Integer;
|
|
{ return font size of the Main Form in the application }
|
|
begin
|
|
Result := MainFont.Size;
|
|
end;
|
|
|
|
function FontWidthSubPixel( Font: TFont): real;
|
|
{ return in pixels the average character width of the font passed in FontHandle }
|
|
var
|
|
TotalWidth: integer;
|
|
begin
|
|
TotalWidth := TextWidthByFont( Font.Handle,
|
|
'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz');
|
|
result := TotalWidth / 52;
|
|
end;
|
|
|
|
function FontWidthPixel( Font: TFont): integer;
|
|
begin
|
|
//Round() is too fancy to be correct here
|
|
result := Trunc(FontWidthSubPixel(Font) + 0.5);
|
|
end;
|
|
|
|
function MainFontWidth: Integer;
|
|
begin
|
|
Result := FontWidthPixel(MainFont);
|
|
end;
|
|
|
|
function MainFontHeight: Integer;
|
|
{ return font size of the Main Form in the application.
|
|
Note that TFont.Height is negative of what we want (see Delphi documentation)}
|
|
begin
|
|
Result := Abs(MainFont.Height);
|
|
end;
|
|
|
|
procedure RedrawSuspend(AHandle: HWnd);
|
|
begin
|
|
SendMessage(AHandle, WM_SETREDRAW, 0, 0);
|
|
end;
|
|
|
|
procedure RedrawActivate(AHandle: HWnd);
|
|
begin
|
|
SendMessage(AHandle, WM_SETREDRAW, 1, 0);
|
|
InvalidateRect(AHandle, nil, True);
|
|
end;
|
|
|
|
procedure ResetSelectedForList(AListBox: TListBox);
|
|
var
|
|
i: Integer;
|
|
begin
|
|
with AListBox do for i := 0 to Items.Count - 1 do Selected[i] := False;
|
|
end;
|
|
|
|
function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
|
|
begin
|
|
result := Trunc( OldWidth *FontWidthSubPixel(NewFont) / FontWidthSubPixel(OldFont)
|
|
+0.5);
|
|
end;
|
|
|
|
function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
|
|
begin
|
|
result := Trunc( OldHeight *Abs(NewFont.Height) / Abs(OldFont.Height)
|
|
+0.5);
|
|
end;
|
|
|
|
procedure ResizeToFont(FontSize: Integer; var W, H: Integer);
|
|
{ resizes form relative to the font size, assumes form designed with
|
|
DefaultFont (>MS Sans Serif 8pt<) }
|
|
var
|
|
Font: TFont;
|
|
begin
|
|
Font := TFont.Create;
|
|
Font.Name := BaseFontName;
|
|
Font.Size := FontSize;
|
|
W := ResizeWidth( BaseFont, Font, W);
|
|
H := ResizeHeight( BaseFont, Font, H);
|
|
end;
|
|
|
|
procedure ResizeHeaderControl( OldFont: TFont; NewFont: TFont; Control: THeaderControl);
|
|
{Tested against fOrders page.}
|
|
var
|
|
i: integer;
|
|
begin
|
|
for i := 0 to Control.Sections.Count-1 do
|
|
Control.Sections[i].Width := ResizeWidth( OldFont, NewFont, Control.Sections[i].Width);
|
|
end;
|
|
|
|
procedure ResizeListView( OldFont: TFont; NewFont: TFont; Control: TListView);
|
|
var
|
|
i: integer;
|
|
begin
|
|
if not Assigned(Control.OnResize) then
|
|
for i := 0 to Control.Columns.Count-1 do
|
|
Control.Columns[i].Width := ResizeWidth( OldFont, NewFont, Control.Columns[i].Width);
|
|
end;
|
|
|
|
procedure ResizeComboBox( OldFont: TFont; NewFont: TFont; Control: TComboBox);
|
|
begin
|
|
Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
|
|
end;
|
|
|
|
procedure ResizeListBox( OldFont: TFont; NewFont: TFont; Control: TListBox);
|
|
begin
|
|
Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
|
|
end;
|
|
|
|
procedure ResizeCheckListBox( OldFont: TFont; NewFont: TFont; Control: TCheckListBox);
|
|
begin
|
|
Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
|
|
end;
|
|
|
|
procedure ResizeDescendants( OldFont: TFont; NewFont: TFont; AControl: TWinControl);
|
|
var
|
|
i: integer;
|
|
Child: TControl;
|
|
VisibleWidth, TotalWidth: integer;
|
|
VisibleHeight, TotalHeight: integer;
|
|
begin
|
|
if AControl.Align <> alNone then
|
|
Application.ProcessMessages;
|
|
AControl.DisableAlign;
|
|
try
|
|
//I think I finally got this next part right, so I will try to explain what
|
|
//it is doing.
|
|
//At this stage, the control is resized, but all of the childern are in
|
|
//original size.
|
|
//These children are corretly aligned to the visible part of the control,
|
|
//but may not be correctly aligned in the underlying canvas if there are
|
|
//scroll bars.
|
|
//We wish to transform the children to have the correct new size and be
|
|
//aligned to the new underlying canvas size.
|
|
|
|
//For the widths, I have kept track of what parts of the screen we are
|
|
//resizing. The height will work the same way.
|
|
//The notation is A[B]C, where A is the space to the left of the child
|
|
//control, B is the space containing the child control, and C is the space
|
|
//to the right.
|
|
VisibleWidth := AControl.Width;
|
|
VisibleHeight := AControl.Height;
|
|
TotalWidth := VisibleWidth;
|
|
TotalHeight := VisibleHeight;
|
|
if AControl is TScrollingWinControl then
|
|
begin
|
|
TotalWidth := HigherOf(TotalWidth, TScrollingWinControl(AControl).HorzScrollBar.Range);
|
|
TotalHeight := HigherOf(TotalHeight, TScrollingWinControl(AControl).VertScrollBar.Range);
|
|
end;
|
|
for i := 0 to AControl.ControlCount -1 do begin
|
|
Child := AControl.Controls[i];
|
|
//Tab sheets auto-size with their parents
|
|
if not (Child is TTabSheet) then
|
|
with Child do begin
|
|
if [akLeft,akRight] <= Anchors then //X[.]X
|
|
Width := TotalWidth - ResizeWidth( OldFont, NewFont, VisibleWidth - Width)
|
|
else //.[X].
|
|
Width := ResizeWidth( OldFont, NewFont, Width);
|
|
if not(akLeft in Anchors) then //.[X]X
|
|
Left := TotalWidth - ResizeWidth( OldFont, NewFont, VisibleWidth - Left)
|
|
else
|
|
Left := ResizeWidth( OldFont, NewFont, Left); //X[.].
|
|
if [akTop,akBottom] <= Anchors then
|
|
Height := TotalHeight - ResizeHeight( OldFont, NewFont, VisibleHeight - Height)
|
|
else
|
|
Height := ResizeHeight( OldFont, NewFont, Height);
|
|
if not(akTop in Anchors) then
|
|
Top := TotalHeight - ResizeHeight( OldFont, NewFont, VisibleHeight - Top)
|
|
else
|
|
Top := ResizeHeight( OldFont, NewFont, Top);
|
|
end;
|
|
//Recurse. Let Auto-Size panels take care of themselves
|
|
if (Child is TWinControl) and not (Child is TORAutoPanel) then
|
|
ResizeDescendants( OldFont, NewFont, TWinControl(Child));
|
|
if Child is TComboBox then
|
|
ResizeComboBox( OldFont, NewFont, TComboBox(Child));
|
|
if Child is TCheckListBox then
|
|
ResizeCheckListBox( OldFont, NewFont, TCheckListBox(Child));
|
|
if Child is THeaderControl then
|
|
ResizeHeaderControl( OldFont, NewFont, THeaderControl(Child));
|
|
if Child is TListBox then
|
|
ResizeListBox( OldFont, NewFont, TListBox(Child));
|
|
if Child is TListView then
|
|
ResizeListView( OldFont, NewFont, TListView(Child));
|
|
if Child is TDrawGrid then with TDrawGrid(Child) do
|
|
//from Win32 "How to Calculate the Height of Edit Control..."
|
|
DefaultRowHeight := Abs(NewFont.Height) * 3 div 2;
|
|
if Child is TTabControl then with TTabControl(Child) do begin
|
|
if Tabs.Count > 0 then
|
|
TabWidth := ResizeWidth( OldFont, NewFont, TabWidth);
|
|
Width := TabWidth * Tabs.Count +3;
|
|
end;
|
|
end;
|
|
finally
|
|
AControl.EnableAlign;
|
|
end;
|
|
end;
|
|
|
|
procedure ResizeChartFonts( OldFont: TFont; NewFont: TFont; Control: TChart);
|
|
var
|
|
i: integer;
|
|
begin
|
|
with Control do begin
|
|
if LeftAxis.Title.Font.Size = OldFont.Size then
|
|
LeftAxis.Title.Font.Size := NewFont.Size;
|
|
if LeftAxis.LabelsFont.Size = OldFont.Size then
|
|
LeftAxis.LabelsFont.Size := NewFont.Size;
|
|
if BottomAxis.Title.Font.Size = OldFont.Size then
|
|
BottomAxis.Title.Font.Size := NewFont.Size;
|
|
if BottomAxis.LabelsFont.Size = OldFont.Size then
|
|
BottomAxis.LabelsFont.Size := NewFont.Size;
|
|
if Legend.Font.Size = OldFont.Size then
|
|
Legend.Font.Size := NewFont.Size;
|
|
if Title.Font.Size = OldFont.Size then
|
|
Title.Font.Size := NewFont.Size;
|
|
for i := 0 to SeriesCount - 1 do
|
|
if Series[i].Marks.Font.Size = OldFont.Size then
|
|
Series[i].Marks.Font.Size := NewFont.Size;
|
|
end;
|
|
end;
|
|
|
|
procedure ResizeFontsInDescendants( OldFont: TFont; NewFont: TFont; AControl: TWinControl);
|
|
var
|
|
i: integer;
|
|
Child: TControl;
|
|
RESelectionStart: integer;
|
|
RESelectionLength: integer;
|
|
begin
|
|
for i := 0 to AControl.ControlCount -1 do begin
|
|
Child := AControl.Controls[i];
|
|
if Child is TRichEdit then begin
|
|
with TRichEdit(Child) do
|
|
if Font.Size = OldFont.Size then begin
|
|
if not ParentFont then
|
|
Font.Size := NewFont.Size;
|
|
RESelectionStart := SelStart;
|
|
RESelectionLength := SelLength;
|
|
SelectAll;
|
|
SelAttributes.Size := NewFont.Size;
|
|
DefAttributes.Size := NewFont.Size;
|
|
SelStart := RESelectionStart;
|
|
SelLength := RESelectionLength;
|
|
end
|
|
end
|
|
else
|
|
if Child is TChart then
|
|
ResizeChartFonts( OldFont, NewFont, TChart(Child))
|
|
else
|
|
with TFontControl(Child) do
|
|
if (Font.Size = OldFont.Size) and not ParentFont then
|
|
Font.Size := NewFont.Size;
|
|
|
|
if Child is TWinControl then
|
|
ResizeFontsInDescendants( OldFont, NewFont, TWinControl(Child));
|
|
end;
|
|
end;
|
|
|
|
procedure ForceInsideWorkArea( var Rect: TRect);
|
|
var
|
|
Frame: TRect;
|
|
begin
|
|
Frame := Screen.WorkAreaRect;
|
|
{Veritcal version:}
|
|
{Align bottom (preserving height) if needed}
|
|
if Rect.Bottom > Frame.Bottom then
|
|
begin
|
|
Rect.Top := Rect.Top + Frame.Bottom - Rect.Bottom;
|
|
Rect.Bottom := Frame.Bottom;
|
|
end;
|
|
{Then align top (preserving height) if needed}
|
|
if Rect.Top < Frame.Top then
|
|
begin
|
|
Rect.Bottom := Rect.Bottom + Frame.Top - Rect.Top;
|
|
Rect.Top := Frame.Top;
|
|
end;
|
|
{Now shrink (preserving top) if needed}
|
|
if Rect.Bottom > Frame.Bottom then
|
|
Rect.Bottom := Frame.Bottom;
|
|
{Horizontal version:}
|
|
if Rect.Right > Frame.Right then
|
|
begin
|
|
Rect.Left := Rect.Left + Frame.Right - Rect.Right;
|
|
Rect.Right := Frame.Right;
|
|
end;
|
|
if Rect.Left < Frame.Left then
|
|
begin
|
|
Rect.Right := Rect.Right + Frame.Left - Rect.Left;
|
|
Rect.Left := Frame.Left;
|
|
end;
|
|
if Rect.Right > Frame.Right then
|
|
Rect.Right := Frame.Right;
|
|
end;
|
|
|
|
procedure ResizeFormToFont(AForm: TForm);
|
|
var
|
|
Rect: TRect;
|
|
begin
|
|
with AForm do begin
|
|
ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
|
|
ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
|
|
HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
|
|
VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
|
|
Rect := BoundsRect;
|
|
ForceInsideWorkArea(Rect);
|
|
BoundsRect := Rect;
|
|
ResizeFontsInDescendants( Font, MainFont, AForm);
|
|
//Important: We are using the font to calculate everything, so don't
|
|
//change font until now.
|
|
Font.Size := MainFont.Size;
|
|
end;
|
|
end;
|
|
|
|
procedure ResizeAnchoredFormToFont( AForm: TForm);
|
|
var
|
|
Rect: TRect;
|
|
begin
|
|
with AForm do begin
|
|
ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
|
|
ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
|
|
HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
|
|
VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
|
|
Rect := BoundsRect;
|
|
ForceInsideWorkArea(Rect);
|
|
BoundsRect := Rect;
|
|
ResizeDescendants( Font, MainFont, AForm);
|
|
ResizeFontsInDescendants( Font, MainFont, AForm);
|
|
//Important: We are using the font to calculate everything, so don't
|
|
//change font until now.
|
|
Font.Size := MainFont.Size;
|
|
end;
|
|
end;
|
|
|
|
procedure SetEqualTabStops(AControl: TControl; TabWidth: Integer = 8);
|
|
{ sets tab stops to match the width when the tab is replaced with TabWidth spaces }
|
|
const
|
|
MAX_TABS = 10;
|
|
POINTS_PER_INCH = 72;
|
|
var
|
|
DC: HDC;
|
|
i, HorzPixelsPerInch, PixelsPerTabWidth, PointsPerTabWidth: Integer;
|
|
begin
|
|
if AControl is TRichEdit then with TRichEdit(AControl) do
|
|
begin
|
|
DC := GetDC(0);
|
|
HorzPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSX);
|
|
ReleaseDC(0, DC);
|
|
PixelsPerTabWidth := TextWidthByFont(Font.Handle, StringOfChar(' ', TabWidth));
|
|
PointsPerTabWidth := Round((PixelsPerTabWidth / HorzPixelsPerInch) * POINTS_PER_INCH);
|
|
for i := 0 to MAX_TABS do Paragraph.Tab[i] := PointsPerTabWidth * Succ(i);
|
|
end;
|
|
end;
|
|
|
|
procedure StatusText(const S: string);
|
|
{ sends a user defined message to the main window of an application to display the text
|
|
found in lParam. Only useful if the main window has message event for this message }
|
|
begin
|
|
if (Application.MainForm <> nil) and (Application.MainForm.HandleAllocated)
|
|
then SendMessage(Application.MainForm.Handle, UM_STATUSTEXT, 0, Integer(PChar(S)));
|
|
end;
|
|
|
|
function ShowMsgOn(AnExpression: Boolean; const AMsg, ACaption: string): Boolean;
|
|
begin
|
|
Result := AnExpression;
|
|
if Result then InfoBox(AMsg, ACaption, MB_OK);
|
|
end;
|
|
|
|
function TextWidthByFont(AFontHandle: THandle; const x: string): Integer;
|
|
{ returns the width of a string in pixels, given a FONT handle and string }
|
|
var
|
|
DC: HDC;
|
|
SaveFont: HFont;
|
|
TextSize: TSize;
|
|
begin
|
|
DC := GetDC(0);
|
|
SaveFont := SelectObject(DC, AFontHandle);
|
|
GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
|
|
Result := TextSize.cx;
|
|
SelectObject(DC, SaveFont);
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
|
|
function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
|
|
var
|
|
DC: HDC;
|
|
SaveFont: HFont;
|
|
TextSize: TSize;
|
|
|
|
begin
|
|
DC := GetDC(0);
|
|
SaveFont := SelectObject(DC, AFontHandle);
|
|
GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
|
|
Result := TextSize.cy;
|
|
SelectObject(DC, SaveFont);
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
|
|
function WrappedTextHeightByFont(Canvas: TCanvas; NewFont: TFont; ItemText: string; var ARect: TRect): integer;
|
|
var
|
|
MyTextMetric: TTextMetric;
|
|
MyFontName: Array [0..31] of char;
|
|
MyFontHandle, RealFontHandle: HFONT;
|
|
begin
|
|
{ The next bit is a bunch of Windows code to accomodate the DrawText calls
|
|
inside the try..finally block. The issue here comes when resizing the font.
|
|
The Delphi font property is already set, but the DrawText call uses a
|
|
Windows handle and the handle's font hasn't been set to the new value.}
|
|
{This still has a vertical sizing bug when there is text that doesn't wrap but is too
|
|
wide to display in the window (think long medicine names and 24 pt font on a
|
|
640*480 screen)}
|
|
MyFontHandle := 0;
|
|
RealFontHandle := 0;
|
|
if GetTextMetrics(Canvas.Handle, MyTextMetric) then
|
|
if GetTextFace( Canvas.Handle, 32, @MyFontName) <> 0 then with MyTextMetric do
|
|
MyFontHandle := CreateFont( NewFont.Height,
|
|
tmAveCharWidth * Abs(NewFont.Height) div tmHeight,
|
|
0,
|
|
0,
|
|
tmWeight,
|
|
tmItalic,
|
|
tmUnderlined,
|
|
tmStruckOut,
|
|
tmCharSet,
|
|
OUT_DEFAULT_PRECIS,
|
|
CLIP_DEFAULT_PRECIS,
|
|
DEFAULT_QUALITY,
|
|
FF_DONTCARE or DEFAULT_PITCH,
|
|
@MyFontName);
|
|
if MyFontHandle <> 0 then
|
|
RealFontHandle := SelectObject( Canvas.Handle, MyFontHandle);
|
|
try
|
|
result := DrawText(Canvas.Handle, PChar(ItemText), Length(ItemText), ARect,
|
|
DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK) + 2;
|
|
finally
|
|
if MyFontHandle <> 0 then begin
|
|
SelectObject( Canvas.Handle, RealFontHandle);
|
|
DeleteObject( MyFontHandle );
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function NumCharsFitInWidth(AFontHandle: THandle; const x: string; const MaxLen: integer): Integer;
|
|
var
|
|
DC: HDC;
|
|
SaveFont: HFont;
|
|
TextSize: TSize;
|
|
TmpX: string;
|
|
done: boolean;
|
|
l,h: integer;
|
|
|
|
begin
|
|
DC := GetDC(0);
|
|
SaveFont := SelectObject(DC, AFontHandle);
|
|
try
|
|
h := length(x);
|
|
l := 0;
|
|
Result := h;
|
|
repeat
|
|
TmpX := copy(x, 1, Result);
|
|
GetTextExtentPoint32(DC, PChar(TmpX), Length(TmpX), TextSize);
|
|
if(TextSize.cx > MaxLen) then
|
|
begin
|
|
h := Result;
|
|
Result := (l+h) div 2;
|
|
done := (Result <= l);
|
|
end
|
|
else
|
|
begin
|
|
l := Result;
|
|
Result := (l+h+1) div 2;
|
|
done := (Result >= h);
|
|
end;
|
|
until(done);
|
|
finally
|
|
SelectObject(DC, SaveFont);
|
|
ReleaseDC(0, DC);
|
|
end;
|
|
end;
|
|
|
|
function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
|
|
begin
|
|
if(assigned(PopupMenu) and assigned(Sender) and (Sender is TPopupMenu) and
|
|
assigned(PopupMenu.PopupComponent)) then
|
|
Result := PopupMenu.PopupComponent
|
|
else
|
|
Result := Screen.ActiveControl;
|
|
end;
|
|
|
|
procedure ReformatMemoParagraph(AMemo: TCustomMemo);
|
|
{ rewrap lines starting with current line until there is a line that starts with whitespace }
|
|
var
|
|
ALine: Integer;
|
|
x, OldText, NewText: string;
|
|
begin
|
|
with AMemo do
|
|
begin
|
|
ALine := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
|
|
repeat
|
|
Inc(ALine);
|
|
until (ALine >= Lines.Count) or (Lines[ALine] = '') or (Ord(Lines[ALine][1]) <= 32);
|
|
SelLength := SendMessage(Handle, EM_LINEINDEX, ALine, 0) - SelStart - 1;
|
|
if SelLength < 1 then Exit;
|
|
OldText := SelText;
|
|
NewText := '';
|
|
repeat
|
|
x := Copy(OldText, 1, Pos(CRLF, OldText) - 1);
|
|
if Length(x) = 0 then x := OldText;
|
|
Delete(OldText, 1, Length(x) + 2); {delete text + CRLF}
|
|
if (NewText <> '') and (Copy(NewText, Length(NewText), 1) <> ' ') and
|
|
(Copy(x, 1, 1) <> ' ') then NewText := NewText + ' ';
|
|
NewText := NewText + x;
|
|
until OldText = '';
|
|
SelText := NewText;
|
|
end;
|
|
end;
|
|
|
|
var
|
|
uReadOnlyColor: TColor;
|
|
uHaveReadOnlyColor: boolean = FALSE;
|
|
|
|
function ReadOnlyColor: TColor;
|
|
begin
|
|
if not uHaveReadOnlyColor then
|
|
begin
|
|
uHaveReadOnlyColor := TRUE;
|
|
if ColorToRGB(clWindow) = ColorToRGB(clWhite) then
|
|
uReadOnlyColor := $00F0FBFF
|
|
else
|
|
uReadOnlyColor := clWindow;
|
|
end;
|
|
Result := uReadOnlyColor;
|
|
end;
|
|
|
|
{ ListBox Grid functions }
|
|
|
|
procedure ListGridDrawCell(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
|
const x: string; WordWrap: Boolean);
|
|
var
|
|
i, Format: Integer;
|
|
ARect: TRect;
|
|
begin
|
|
ARect := AListBox.ItemRect(ARow);
|
|
ARect.Left := 0;
|
|
for i := 0 to AColumn - 1 do ARect.Left := ARect.Left + AHeader.Sections[i].Width;
|
|
Inc(ARect.Left, 2);
|
|
ARect.Right := ARect.Left + AHeader.Sections[AColumn].Width - 6;
|
|
if WordWrap
|
|
then Format := (DT_LEFT or DT_NOPREFIX or DT_WORDBREAK)
|
|
else Format := (DT_LEFT or DT_NOPREFIX);
|
|
DrawText(AListBox.Canvas.Handle, PChar(x), Length(x), ARect, Format);
|
|
end;
|
|
|
|
procedure ListGridDrawLines(AListBox: TListBox; AHeader: THeaderControl; Index: Integer;
|
|
State: TOwnerDrawState);
|
|
var
|
|
i, RightSide: Integer;
|
|
ARect: TRect;
|
|
begin
|
|
with AListBox do
|
|
begin
|
|
ARect := ItemRect(Index);
|
|
if odSelected in State then
|
|
begin
|
|
Canvas.Brush.Color := clHighlight;
|
|
Canvas.Font.Color := clHighlightText
|
|
end;
|
|
Canvas.FillRect(ARect);
|
|
Canvas.Pen.Color := clSilver;
|
|
Canvas.MoveTo(ARect.Left, ARect.Bottom - 1);
|
|
Canvas.LineTo(ARect.Right, ARect.Bottom - 1);
|
|
RightSide := -2;
|
|
for i := 0 to AHeader.Sections.Count - 1 do
|
|
begin
|
|
RightSide := RightSide + AHeader.Sections[i].Width;
|
|
Canvas.MoveTo(RightSide, ARect.Bottom - 1);
|
|
Canvas.LineTo(RightSide, ARect.Top);
|
|
end;
|
|
end;
|
|
end;
|
|
|
|
function ListGridRowHeight(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
|
const x: string): Integer;
|
|
var
|
|
ARect: TRect;
|
|
begin
|
|
ARect := AListBox.ItemRect(ARow);
|
|
ARect.Right := AHeader.Sections[AColumn].Width - 6;
|
|
Result := DrawText(AListBox.Canvas.Handle, PChar(x), Length(x), ARect,
|
|
DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK) + 2;
|
|
end;
|
|
|
|
(*
|
|
procedure SetEditWidth(AMemo: TMemo; AWidth: Integer);
|
|
begin
|
|
//SetString(x, nil, AWidth);
|
|
//for i := 1 to AWidth do x[i] := 'X';
|
|
end;
|
|
*)
|
|
|
|
{ You MUST pass an address to an object variable to get KillObj to work }
|
|
procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
|
|
var
|
|
Obj: TObject;
|
|
Lst: TList;
|
|
SLst: TStringList;
|
|
i: integer;
|
|
|
|
begin
|
|
Obj := TObject(ptr^);
|
|
if(assigned(Obj)) then
|
|
begin
|
|
if(KillObjects) then
|
|
begin
|
|
if(Obj is TList) then
|
|
begin
|
|
Lst := TList(Obj);
|
|
for i := Lst.count-1 downto 0 do
|
|
if assigned(Lst[i]) then
|
|
TObject(Lst[i]).Free;
|
|
end
|
|
else
|
|
if(Obj is TStringList) then
|
|
begin
|
|
SLst := TStringList(Obj);
|
|
for i := SLst.count-1 downto 0 do
|
|
if assigned(SLst.Objects[i]) then
|
|
SLst.Objects[i].Free;
|
|
end;
|
|
end;
|
|
Obj.Free;
|
|
TObject(ptr^) := nil;
|
|
end;
|
|
end;
|
|
|
|
{ Idle Processing }
|
|
|
|
type
|
|
TIdleCaller = class(TObject)
|
|
private
|
|
FTimerActive: boolean;
|
|
FCallList: TStringList;
|
|
FDoneList: TStringList;
|
|
FOldIdler: TIdleEvent;
|
|
FTimer: TTimer;
|
|
protected
|
|
procedure AppIdle(Sender: TObject; var Done: Boolean);
|
|
procedure TimerDone(Sender: TObject);
|
|
public
|
|
constructor Create;
|
|
destructor Destroy; override;
|
|
procedure Add(CallProc, DoneProc: TORIdleCallProc; Msg: string);
|
|
end;
|
|
|
|
var
|
|
IdleCaller: TIdleCaller = nil;
|
|
|
|
{ TIdleCaller }
|
|
|
|
constructor TIdleCaller.Create;
|
|
begin
|
|
inherited;
|
|
FCallList := TStringList.Create;
|
|
FDoneList := TStringList.Create;
|
|
FTimer := TTimer.Create(nil);
|
|
FTimer.Enabled := FALSE;
|
|
FTimer.Interval := 2000; // 2 seconds
|
|
FTimer.OnTimer := TimerDone;
|
|
FTimerActive := FALSE;
|
|
FOldIdler := Application.OnIdle;
|
|
Application.OnIdle := AppIdle;
|
|
end;
|
|
|
|
destructor TIdleCaller.Destroy;
|
|
begin
|
|
Application.OnIdle := FOldIdler;
|
|
FTimer.Enabled := FALSE;
|
|
KillObj(@FTimer);
|
|
KillObj(@FDoneList);
|
|
KillObj(@FCallList);
|
|
inherited;
|
|
end;
|
|
|
|
procedure TIdleCaller.AppIdle(Sender: TObject; var Done: Boolean);
|
|
begin
|
|
if(not FTimerActive) and (FCallList.Count > 0) then
|
|
begin
|
|
FTimer.Enabled := TRUE;
|
|
FTimerActive := TRUE;
|
|
end;
|
|
if assigned(FOldIdler) then
|
|
FOldIdler(Sender, Done);
|
|
end;
|
|
|
|
procedure TIdleCaller.Add(CallProc, DoneProc: TORIdleCallProc; Msg: string);
|
|
begin
|
|
FCallList.AddObject(Msg, TObject(@CallProc));
|
|
FDoneList.AddObject(Msg, TObject(@DoneProc));
|
|
end;
|
|
|
|
procedure TIdleCaller.TimerDone(Sender: TObject);
|
|
var
|
|
CallProc, DoneProc: TORIdleCallProc;
|
|
CallMsg, DoneMsg: string;
|
|
|
|
begin
|
|
FTimer.Enabled := FALSE;
|
|
CallProc := TORIdleCallProc(FCallList.Objects[0]);
|
|
CallMsg := FCallList[0];
|
|
DoneProc := TORIdleCallProc(FDoneList.Objects[0]);
|
|
DoneMsg := FDoneList[0];
|
|
FCallList.Delete(0);
|
|
FDoneList.Delete(0);
|
|
|
|
if(assigned(CallProc)) then
|
|
CallProc(CallMsg);
|
|
if(assigned(DoneProc)) then
|
|
DoneProc(DoneMsg);
|
|
|
|
FTimerActive := FALSE;
|
|
end;
|
|
|
|
{ do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet. }
|
|
procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
|
|
begin
|
|
if(not assigned(IdleCaller)) then
|
|
IdleCaller := TIdleCaller.Create;
|
|
IdleCaller.Add(CallProc, nil, Msg);
|
|
end;
|
|
|
|
procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
|
|
begin
|
|
if(not assigned(IdleCaller)) then
|
|
IdleCaller := TIdleCaller.Create;
|
|
IdleCaller.Add(CallProc, DoneProc, Msg);
|
|
end;
|
|
|
|
procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
|
|
var
|
|
aCount, bCount: integer;
|
|
butFound: boolean;
|
|
begin
|
|
for aCount := 0 to (aMenuItem.count - 1) do // Iterate through menu items.
|
|
begin
|
|
butFound := false;
|
|
for bCount := 0 to (length(butItems) - 1) do // Check for match in exceptions array.
|
|
begin
|
|
if (aMenuItem.items[aCount] = butItems[bCount]) then
|
|
begin
|
|
butFound := true;
|
|
break;
|
|
end;
|
|
end;
|
|
if (not butFound) then
|
|
aMenuItem.items[aCount].visible := false; // Hide menu item if not an exception.
|
|
end;
|
|
end;
|
|
|
|
function TabIsPressed : Boolean;
|
|
begin
|
|
Result := Boolean(Hi(GetKeyState(VK_TAB))) and not Boolean(Hi(GetKeyState(VK_SHIFT)));
|
|
end;
|
|
|
|
function ShiftTabIsPressed : Boolean;
|
|
begin
|
|
Result := Boolean(Hi(GetKeyState(VK_TAB))) and Boolean(Hi(GetKeyState(VK_SHIFT)));
|
|
end;
|
|
|
|
|
|
initialization
|
|
FBaseFont := TFont.Create;
|
|
FBaseFont.Name := BaseFontName;
|
|
FBaseFont.Size := BaseFontSize;
|
|
|
|
finalization
|
|
FBaseFont.Free;
|
|
KillObj(@IdleCaller);
|
|
|
|
end. |