VistA-cprs/CPRS-Lib/ORFn.pas

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.