iSharkFly-Open
/
VistA-cprs
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
VistA-cprs/CPRS-Lib/ORFn.pas

2309 lines
72 KiB
Plaintext
Raw Permalink Blame History

unit ORFn;
{$OPTIMIZATION OFF}
interface // --------------------------------------------------------------------------------
uses SysUtils, Windows, Messages, Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Forms,
Graphics, Menus, RichEdit, Buttons;
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
var
ScrollBarHeight: integer = 0;
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;
function RectContains(Rect: TRect; Point: TPoint): boolean;
{ String functions }
function CharAt(const x: string; APos: Integer): Char;
function ContainsAlpha(const x: string): Boolean;
function ContainsVisibleChar(const x: string): Boolean;
function ContainsUpCarretChar(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);
procedure QuickAdd(AFrom, ATo: TObject);
procedure FastAssign(source, destination: TStrings);
procedure FastAddStrings(source, destination: TStrings);
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);
procedure AdjustForWindowsXPStyleTitleBar(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 BlackColorScheme: Boolean;
function NormalColorScheme: Boolean;
function Get508CompliantColor(Color: TColor): TColor;
procedure UpdateColorsFor508Compliance(control: TControl; InputEditControl: boolean = FALSE);
procedure UpdateReadOnlyColorScheme(Control: TControl; ReadOnly: boolean);
{ 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 }
function CPRSInstances: integer;
{ 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;
function EnterIsPressed : Boolean;
procedure ScrollControl(Window: TScrollingWinControl; ScrollingUp: boolean; Amount: integer = 40);
implementation // ---------------------------------------------------------------------------
uses
ORCtrls, Grids, Chart, CheckLst, VAUtils;
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;
function RectContains(Rect: TRect; Point: TPoint): boolean;
begin
Result := ((Point.X >= Rect.Left) and
(Point.X <= Rect.Right) and
(Point.Y >= Rect.Top) and
(Point.Y <= Rect.Bottom));
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 ContainsUpCarretChar(const x: string): Boolean;
{ returns true if the string contains the ^ character }
var
i: Integer;
begin
Result := False;
for i := 1 to Length(x) do if x[i] = '^' 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 }
begin
Result := VAUtils.Piece(S, Delim, PieceNum);
end;
function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
begin
Result := VAUtils.Pieces(S, Delim, FirstNum, LastNum);
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 TORComboBox then
str[idx] := TORComboBox(obj).Items
else
if obj is TComboBox then
str[idx] := TComboBox(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;
if ATo is TRichEdit then
TRichEdit(ATo).SelStart := Length(TRichEdit(ATo).Lines.Text); //CQ: 16461
end;
type
QuickAddError = class(Exception);
procedure QuickAdd(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 QuickAdd, 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 TORComboBox then
str[idx] := TORComboBox(obj).Items
else
if obj is TComboBox then
str[idx] := TComboBox(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 QuickAddError.Create('Unsupported object type (' + obj.ClassName +
') passed into QuickAdd.');
inc(idx);
end;
begin
fix[0] := FALSE;
fix[1] := FALSE;
idx := 0;
GetStrings(AFrom);
GetStrings(ATo);
ms := TMemoryStream.Create;
try
str[1].SaveToStream(ms);
ms.Seek(0, soFromEnd);
str[0].SaveToStream(ms);
ms.Seek(0, soFromBeginning);
str[1].Clear;
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;
procedure FastAssign(source, destination: TStrings);
// do not use this with RichEdit Lines unless source is RichEdit with PlainText
var
ms: TMemoryStream;
begin
destination.Clear;
if (source is TStringList) and (destination is TStringList) then
destination.Assign(source)
else
if (CompareText(source.ClassName, 'TRichEditStrings') = 0) then
destination.Assign(source)
else
begin
ms := TMemoryStream.Create;
try
source.SaveToStream(ms);
ms.Seek(0, soFromBeginning);
destination.LoadFromStream(ms);
finally
ms.Free;
end;
end;
end;
procedure FastAddStrings(source, destination: TStrings);
// do not use this with RichEdit Lines unless source and destination are RichEdit with PlainText
var
ms: TMemoryStream;
begin
if (source is TStringList) and (destination is TStringList) then
destination.AddStrings(source)
else
begin
ms := TMemoryStream.Create;
try
destination.SaveToStream(ms);
ms.Seek(0, soFromEnd);
source.SaveToStream(ms);
ms.Seek(0, soFromBeginning);
destination.Clear;
destination.LoadFromStream(ms);
finally
ms.Free;
end;
end;
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;
FastAssign(NewList, AList);
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;
var
AlignList, AnchorList: TStringList;
function AnchorsToStr(Control: TControl): string;
var
j: TAnchorKind;
begin
Result := '';
for j := low(TAnchorKind) to high(TAnchorKind) do
if j in Control.Anchors then
Result := result + '1'
else
Result := result + '0'
end;
function StrToAnchors(i: integer): TAnchors;
var
j: TAnchorKind;
value: string;
idx : integer;
begin
Result := [];
value := AnchorList[i];
idx := 1;
for j := low(TAnchorKind) to high(TAnchorKind) do
begin
if copy(value,idx,1) = '1' then
include(Result, j);
inc(idx);
end;
end;
procedure SuspendAlign(AForm: TForm);
var
i: integer;
control: TControl;
begin
AForm.DisableAlign;
AlignList.Clear;
AnchorList.Clear;
for i := 0 to AForm.ControlCount-1 do
begin
control := AForm.Controls[i];
AlignList.Add(IntToStr(ord(control.align)));
control.Align := alNone;
AnchorList.Add(AnchorsToStr(control));
control.Anchors := [];
end;
end;
procedure RestoreAlign(AForm: TForm);
var
i: integer;
control: TControl;
begin
try
for i := 0 to AForm.ControlCount-1 do
begin
control := AForm.Controls[i];
control.Align := TAlign(StrToIntDef(AlignList[i],0));
control.Anchors := StrToAnchors(i);
end;
AlignList.Clear;
AnchorList.Clear;
finally
AForm.EnableAlign;
end;
end;
procedure ResizeFormToFont(AForm: TForm);
var
Rect: TRect;
OldResize: TNotifyEvent;
begin
// CQ# 11481 apply size changes to form all at once, instead of piece by piece. Otherwise,
// multiple calls to fAutoSz.FormResize, even if the form has not resized, can distort
// the controls beyond the size of the form.
with AForm do begin
OldResize := AForm.OnResize;
AForm.OnResize := nil;
try
SuspendAlign(AForm);
try
HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
Rect := BoundsRect;
ForceInsideWorkArea(Rect);
BoundsRect := Rect;
finally
RestoreAlign(AForm);
end;
ResizeFontsInDescendants( Font, MainFont, AForm);
//Important: We are using the font to calculate everything, so don't
//change font until now.
Font.Size := MainFont.Size;
finally
if(Assigned(OldResize)) then
begin
AForm.OnResize := OldResize;
OldResize(AForm);
end;
end;
end;
end;
procedure ResizeAnchoredFormToFont( AForm: TForm);
var
Rect: TRect;
OldResize: TNotifyEvent;
begin
with AForm do begin
// CQ# 11481 - see ResizeFormToFont
OldResize := AForm.OnResize;
AForm.OnResize := nil;
try
HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
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;
finally
if(Assigned(OldResize)) then
begin
AForm.OnResize := OldResize;
OldResize(AForm);
end;
end;
end;
end;
// CQ 11485 - Adjusts all forms - adds additional height to the form to
// adjust for Windows XP style title bars, and for large fonts in title bar
procedure AdjustForWindowsXPStyleTitleBar(AForm: TForm);
const
DEFAULT_CAPTION_HEIGHT = 19;
DEFAULT_MENU_HEIGHT = 19;
var
dxsb, dysb, dy, menuDY: integer;
begin
// Call GetSystemMetrics each time because values can change between calls
dy := GetSystemMetrics(SM_CYCAPTION) - DEFAULT_CAPTION_HEIGHT;
if (AForm.Menu <> nil) then
begin
menuDY := GetSystemMetrics(SM_CYMENU) - DEFAULT_MENU_HEIGHT;
inc(dy, menuDY);
end;
if dy <> 0 then
begin
SuspendAlign(AForm);
try
// Assitional adjustment to allow scroll bars to dissappear
dxsb := GetSystemMetrics(SM_CXVSCROLL);
dysb := GetSystemMetrics(SM_CYHSCROLL);
AForm.Height := AForm.Height + dy + dysb;
AForm.Width := AForm.Width + dxsb;
AForm.Height := AForm.Height - dysb;
AForm.Width := AForm.Width - dxsb;
finally
RestoreAlign(AForm);
end;
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);
try
SaveFont := SelectObject(DC, AFontHandle);
try
GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
Result := TextSize.cx;
finally
SelectObject(DC, SaveFont);
end;
finally
ReleaseDC(0, DC);
end;
end;
function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
var
DC: HDC;
SaveFont: HFont;
TextSize: TSize;
begin
DC := GetDC(0);
try
SaveFont := SelectObject(DC, AFontHandle);
try
GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
Result := TextSize.cy;
finally
SelectObject(DC, SaveFont);
end;
finally
ReleaseDC(0, DC);
end;
if Result > 255 then // CQ 11493
Result := 255; // This is maximum allowed by a Windows
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;
if Result > 255 then // CQ 11492
Result := 255; // This is maximum allowed by a Windows
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
uNormalColorScheme: boolean = false;
uBlackColorScheme: boolean = false;
uWhiteColorScheme: boolean = false;
uMaroonColorWhenBlack: TColor = clMaroon;
uCheckColorScheme: boolean = true;
PURE_BLACK: longint = 0;
const
uBorderlessWindowColorWhenBlack: TColor = clNavy;
procedure CheckColorScheme;
begin
if uCheckColorScheme then
begin
uNormalColorScheme :=
((ColorToRGB(clWindow) = ColorToRGB(clWhite)) and
(ColorToRGB(clWindowText) = ColorToRGB(clBlack)) and
(ColorToRGB(clInfoText) = ColorToRGB(clBlack)) and
(ColorToRGB(clInfoBk) <> ColorToRGB(clWhite)));
uBlackColorScheme := ((ColorToRGB(clBtnFace) = ColorToRGB(clBlack)) and
(ColorToRGB(clWindow) = ColorToRGB(clBlack)));
uWhiteColorScheme := ((ColorToRGB(clBtnFace) = ColorToRGB(clWhite)) and
(ColorToRGB(clWindow) = ColorToRGB(clWhite)));
if uBlackColorScheme then
begin
if(ColorToRGB(clGrayText) = ColorToRGB(clWindowText)) then
uMaroonColorWhenBlack := clHighlightText
else
uMaroonColorWhenBlack := clGrayText;
end;
uCheckColorScheme := FALSE;
end;
end;
function BlackColorScheme: Boolean;
begin
if uCheckColorScheme then CheckColorScheme;
Result := uBlackColorScheme;
end;
function NormalColorScheme: Boolean;
begin
if uCheckColorScheme then CheckColorScheme;
Result := uNormalColorScheme;
end;
function Get508CompliantColor(Color: TColor): TColor;
begin
Result := Color;
if NormalColorScheme then exit;
case Color of
clCream: Result := clInfoBk;
clBlack: Result := clWindowText;
clWhite: Result := clWindow;
end;
if uBlackColorScheme then
begin
case Color of
clBlue: Result := clAqua;
clMaroon: Result := uMaroonColorWhenBlack;
// clRed: Result := clFuchsia;
end;
end;
if uWhiteColorScheme then
begin
case Color of
clGrayText: Result := clGray;
end;
end;
end;
type
TExposedControl = class(TControl)
public
property Color;
property Font;
end;
TExposedCustomEdit = class(TCustomEdit)
public
property BorderStyle;
property ReadOnly;
end;
procedure UpdateColorsFor508Compliance(control: TControl; InputEditControl: boolean = FALSE);
var
BitMapLevelCheck: integer;
Level: integer;
procedure BlackColorSchemeUpdate(control: TControl);
var
bitmap: TBitMap;
edit: TExposedCustomEdit;
x,y: integer;
cbmCtrl: IORBlackColorModeCompatible;
begin
if uBlackColorScheme then
begin
if Level < BitMapLevelCheck then
begin
if control.GetInterface(IORBlackColorModeCompatible, cbmCtrl) then
begin
cbmCtrl.SetBlackColorMode(TRUE);
BitMapLevelCheck := Level;
cbmCtrl := nil;
end
else
begin
if (control is TBitBtn) then
begin
bitmap := TBitBtn(control).Glyph;
for x := 0 to bitmap.Width-1 do
begin
for y := 0 to bitmap.Height-1 do
begin
if ColorToRGB(bitmap.Canvas.Pixels[x,y]) = PURE_BLACK then
bitmap.Canvas.Pixels[x,y] := clWindowText;
end;
end;
end;
end;
end;
if (control is TCustomEdit) and InputEditControl then
begin
edit := TExposedCustomEdit(control);
if (edit.BorderStyle = bsNone) then
edit.Color := uBorderlessWindowColorWhenBlack;
end;
end;
end;
procedure ComponentUpdateColorsFor508Compliance(control: TControl);
var
OldComponentColor, OldFontColor, NewComponentColor, NewFontColor: TColor;
begin
OldComponentColor := TExposedControl(control).Color;
OldFontColor := TExposedControl(control).Font.Color;
NewComponentColor := Get508CompliantColor(OldComponentColor);
if NewComponentColor = clInfoBk then
begin
if (OldFontColor = clInfoBk) or (OldFontColor = clCream) then
NewFontColor := clInfoBk // used for hiding text
else
NewFontColor := clInfoText;
end
else
NewFontColor := Get508CompliantColor(OldFontColor);
if NewComponentColor <> OldComponentColor then
TExposedControl(control).Color := NewComponentColor;
if NewFontColor <> OldFontColor then
TExposedControl(control).Font.Color := NewFontColor;
BlackColorSchemeUpdate(control);
end;
procedure ScanAllComponents(control: TControl);
var
i: integer;
begin
ComponentUpdateColorsFor508Compliance(Control);
if control is TWinControl then
begin
inc(Level);
try
for i := 0 to TWinControl(Control).ControlCount-1 do
begin
ScanAllComponents(TWinControl(Control).Controls[i]);
end;
finally
dec(Level);
if BitMapLevelCheck = Level then
BitMapLevelCheck := MaxInt;
end;
end;
end;
begin
if NormalColorScheme then exit;
BitMapLevelCheck := MaxInt;
Level := 0;
ScanAllComponents(control);
end;
procedure UpdateReadOnlyColorScheme(Control: TControl; ReadOnly: boolean);
begin
with TExposedControl(Control) do
begin
if ReadOnly then
begin
Color := Get508CompliantColor(clCream);
Font.Color := clInfoText;
end
else
begin
Color := clWindow;
Font.Color := clWindowText;
end;
end;
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 := Get508CompliantColor(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;
*)
function CPRSInstances: integer;
// returns the number of CPRS sessions open
var
AHandle: hWnd;
LengthText, LengthConst, counter: Integer;
CharText: array [0..254] of Char;
TitleText, TitleCompare: string;
const
TX_IN_USE = 'VistA CPRS in use by: '; // use same as in fFrame
begin
counter := 0;
LengthConst := length(TX_IN_USE);
AHandle := FindWindow(nil, nil);
while AHandle <> 0 do begin
LengthText := GetWindowText(AHandle, CharText, 255);
if LengthText > 0 then
begin
TitleText := CharText;
TitleCompare := copy(TitleText, 1, LengthConst);
if TitleCompare = TX_IN_USE then
counter := counter + 1;
end;
AHandle := GetWindow(AHandle, GW_HWNDNEXT);
end;
Result := counter;
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)));
Result := Result and not Boolean(Hi(GetKeyState(VK_CONTROL)));
end;
function ShiftTabIsPressed : Boolean;
begin
Result := Boolean(Hi(GetKeyState(VK_TAB))) and Boolean(Hi(GetKeyState(VK_SHIFT)));
Result := Result and not Boolean(Hi(GetKeyState(VK_CONTROL)));
end;
function EnterIsPressed : Boolean;
begin
Result := Boolean(Hi(GetKeyState(VK_RETURN)));
end;
procedure ScrollControl(Window: TScrollingWinControl; ScrollingUp: boolean; Amount: integer = 40);
var
Delta: integer;
// This is needed to tell the child components that they are moving,
// The TORCombo box, for example, needs to close a dropped down window when it moves.
// If Delphi had used standard scroll bars, instead of the customized flat ones, this
// code wouldn't be needed
procedure SendMoveMessage(Ctrl: TWinControl);
var
i: integer;
begin
for i := 0 to Ctrl.ControlCount - 1 do
begin
if Ctrl.Controls[i] is TWinControl then with TWinControl(Ctrl.Controls[i]) do
begin
SendMessage(Handle, WM_MOVE, 0, (Top * 65536) + Left);
SendMoveMessage(TWinControl(Ctrl.Controls[i]));
end;
end;
end;
begin
Delta := Amount;
if ScrollingUp then
begin
if Window.VertScrollBar.Position < Delta then
Delta := Window.VertScrollBar.Position;
Delta := - Delta;
end
else
begin
if (Window.VertScrollBar.Range - Window.VertScrollBar.Position) < Delta then
Delta := Window.VertScrollBar.Range - Window.VertScrollBar.Position;
end;
if Delta <> 0 then
begin
Window.VertScrollBar.Position := Window.VertScrollBar.Position + Delta;
SendMoveMessage(Window);
end;
end;
initialization
FBaseFont := TFont.Create;
FBaseFont.Name := BaseFontName;
FBaseFont.Size := BaseFontSize;
ScrollBarHeight := GetSystemMetrics(SM_CYHSCROLL);
AlignList := TStringList.Create;
AnchorList := TStringList.Create;
PURE_BLACK := ColorToRGB(clBlack);
finalization
FBaseFont.Free;
KillObj(@IdleCaller);
FreeAndNil(AlignList);
FreeAndNil(AnchorList);
end.
Reference in New Issue View Git Blame Copy Permalink