[453] | 1 | unit ORFn;
|
---|
| 2 |
|
---|
| 3 | {$OPTIMIZATION OFF}
|
---|
| 4 |
|
---|
| 5 | interface // --------------------------------------------------------------------------------
|
---|
| 6 |
|
---|
| 7 | uses SysUtils, Windows, Messages, Classes, Controls, StdCtrls, ExtCtrls, ComCtrls, Forms,
|
---|
| 8 | Graphics, Menus, RichEdit;
|
---|
| 9 |
|
---|
| 10 | const
|
---|
| 11 | U = '^';
|
---|
| 12 | CRLF = #13#10;
|
---|
| 13 | BOOLCHAR: array[Boolean] of Char = ('0', '1');
|
---|
| 14 | UM_STATUSTEXT = (WM_USER + 302); // used to send update status msg to main form
|
---|
| 15 | COLOR_CREAM = $F0FBFF;
|
---|
| 16 |
|
---|
| 17 | type
|
---|
| 18 | TFMDateTime = Double;
|
---|
| 19 | TORIdleCallProc = procedure(Msg: string);
|
---|
| 20 |
|
---|
| 21 | { Date/Time functions }
|
---|
| 22 | function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
|
---|
| 23 | function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
|
---|
| 24 | function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
|
---|
| 25 | function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
|
---|
| 26 | function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
|
---|
| 27 | function IsFMDateTime(x: string): Boolean;
|
---|
| 28 | function MakeFMDateTime(const AString: string): TFMDateTime;
|
---|
| 29 | procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
|
---|
| 30 | PieceNum: Integer; KeepBad: boolean = FALSE);
|
---|
| 31 |
|
---|
| 32 | { Numeric functions }
|
---|
| 33 | function HigherOf(i, j: Integer): Integer;
|
---|
| 34 | function LowerOf(i, j: Integer): Integer;
|
---|
| 35 | function StrToFloatDef(const S: string; ADefault: Extended): Extended;
|
---|
| 36 |
|
---|
| 37 | { String functions }
|
---|
| 38 | function CharAt(const x: string; APos: Integer): Char;
|
---|
| 39 | function ContainsAlpha(const x: string): Boolean;
|
---|
| 40 | function ContainsVisibleChar(const x: string): Boolean;
|
---|
| 41 | function ConvertSpecialStrings(const x: string): String;
|
---|
| 42 | function CRCForFile(AFileName: string): DWORD;
|
---|
| 43 | function CRCForStrings(AStringList: TStrings): DWORD;
|
---|
| 44 | procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
|
---|
| 45 | function ExtractInteger(x: string): Integer;
|
---|
| 46 | function ExtractFloat(x: string): Extended;
|
---|
| 47 | function ExtractDefault(Src: TStrings; const Section: string): string;
|
---|
| 48 | procedure ExtractItems(Dest, Src: TStrings; const Section: string);
|
---|
| 49 | procedure ExtractText(Dest, Src: TStrings; const Section: string);
|
---|
| 50 | function FilteredString(const x: string; ATabWidth: Integer = 8): string;
|
---|
| 51 | procedure InvertStringList(AList: TStringList);
|
---|
| 52 | procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
|
---|
| 53 | function MixedCase(const x: string): string;
|
---|
| 54 | procedure MixedCaseList(AList: TStrings);
|
---|
| 55 | procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
|
---|
| 56 | function Piece(const S: string; Delim: char; PieceNum: Integer): string;
|
---|
| 57 | function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
|
---|
| 58 | function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
|
---|
| 59 | char = '^'; CaseInsensitive: boolean = FALSE): integer;
|
---|
| 60 | procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
|
---|
| 61 | function ReverseStr(const x: string): string;
|
---|
| 62 | procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
|
---|
| 63 | procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
|
---|
| 64 | FromString: string);
|
---|
| 65 | procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
|
---|
| 66 | function DelimCount(const Str, Delim: string): integer;
|
---|
| 67 | procedure QuickCopy(AFrom, ATo: TObject);
|
---|
| 68 | function ValidFileName(const InitialFileName: string): string;
|
---|
| 69 |
|
---|
| 70 | { Display functions }
|
---|
| 71 | procedure ForceInsideWorkArea( var Rect: TRect);
|
---|
| 72 | //procedure ClearControl(AControl: TControl);
|
---|
| 73 | function InfoBox(const Text, Caption: string; Flags: Word): Integer;
|
---|
| 74 | procedure LimitEditWidth(AControl: TWinControl; NumChars: Integer);
|
---|
| 75 | function MainFont: TFont;
|
---|
| 76 | function MainFontSize: Integer;
|
---|
| 77 | function MainFontWidth: Integer;
|
---|
| 78 | function MainFontHeight: Integer;
|
---|
| 79 | function BaseFont: TFont;
|
---|
| 80 | procedure RedrawSuspend(AHandle: HWnd);
|
---|
| 81 | procedure RedrawActivate(AHandle: HWnd);
|
---|
| 82 | //procedure ResetControl(AControl: TControl);
|
---|
| 83 | procedure ResetSelectedForList(AListBox: TListBox);
|
---|
| 84 | procedure ResizeFormToFont(AForm: TForm);
|
---|
| 85 | procedure ResizeAnchoredFormToFont( AForm: TForm);
|
---|
| 86 | function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
|
---|
| 87 | function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
|
---|
| 88 | procedure ResizeToFont(FontSize: Integer; var W, H: Integer);
|
---|
| 89 | procedure SetEqualTabStops(AControl: TControl; TabWidth: Integer = 8);
|
---|
| 90 | procedure StatusText(const S: string);
|
---|
| 91 | function ShowMsgOn(AnExpression: Boolean; const AMsg, ACaption: string): Boolean;
|
---|
| 92 | function TextWidthByFont(AFontHandle: THandle; const x: string): Integer;
|
---|
| 93 | function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
|
---|
| 94 | function WrappedTextHeightByFont(Canvas: TCanvas; NewFont: TFont; ItemText: string; var ARect: TRect): integer;
|
---|
| 95 | function NumCharsFitInWidth(AFontHandle: THandle; const x: string; const MaxLen: integer): Integer;
|
---|
| 96 | function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
|
---|
| 97 | procedure ReformatMemoParagraph(AMemo: TCustomMemo);
|
---|
| 98 | function ReadOnlyColor: TColor;
|
---|
| 99 |
|
---|
| 100 | { ListBox Grid functions }
|
---|
| 101 | procedure ListGridDrawCell(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
---|
| 102 | const x: string; WordWrap: Boolean);
|
---|
| 103 | procedure ListGridDrawLines(AListBox: TListBox; AHeader: THeaderControl; Index: Integer;
|
---|
| 104 | State: TOwnerDrawState);
|
---|
| 105 | function ListGridRowHeight(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
---|
| 106 | const x: string): Integer;
|
---|
| 107 |
|
---|
| 108 | { Misc functions }
|
---|
| 109 | { You MUST pass an address to an object variable to get KillObj to work }
|
---|
| 110 | procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
|
---|
| 111 |
|
---|
| 112 | { do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet }
|
---|
| 113 | procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
|
---|
| 114 | procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
|
---|
| 115 | procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
|
---|
| 116 | function TabIsPressed : Boolean;
|
---|
| 117 | function ShiftTabIsPressed : Boolean;
|
---|
| 118 |
|
---|
| 119 | implementation // ---------------------------------------------------------------------------
|
---|
| 120 |
|
---|
| 121 | uses
|
---|
| 122 | ORCtrls, Grids, Chart, CheckLst;
|
---|
| 123 |
|
---|
| 124 | const
|
---|
| 125 | { names of months used by FormatFMDateTime }
|
---|
| 126 | MONTH_NAMES_SHORT: array[1..12] of string[3] =
|
---|
| 127 | ('Jan','Feb','Mar','Apr','May','Jun','Jul','Aug','Sep','Oct','Nov','Dec');
|
---|
| 128 | MONTH_NAMES_LONG: array[1..12] of string[9] =
|
---|
| 129 | ('January','February','March','April','May','June','July','August','September','October',
|
---|
| 130 | 'November', 'December');
|
---|
| 131 |
|
---|
| 132 | // ConvertSpecialStrings arrays
|
---|
| 133 | SearchChars: array[0..7] of String = (' Ii ',' Iii ',' Iv ',' Vi ',' Vii ',' Viii ',' Ix ','-Va');
|
---|
| 134 | ReplaceChars: array[0..7] of String = (' II ',' III ',' IV ',' VI ',' VII ',' VIII ',' IX ','-VA');
|
---|
| 135 |
|
---|
| 136 | { table for calculating CRC values (DWORD is Integer in Delphi 3, Cardinal in Delphi 4}
|
---|
| 137 | CRC32_TABLE: array[0..255] of DWORD =
|
---|
| 138 | ($0, $77073096, $EE0E612C, $990951BA, $76DC419, $706AF48F, $E963A535, $9E6495A3,
|
---|
| 139 | $EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988, $9B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
|
---|
| 140 | $1DB71064, $6AB020F2, $F3B97148, $84BE41DE, $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
|
---|
| 141 | $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC, $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
|
---|
| 142 | $3B6E20C8, $4C69105E, $D56041E4, $A2677172, $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
|
---|
| 143 | $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940, $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
|
---|
| 144 | $26D930AC, $51DE003A, $C8D75180, $BFD06116, $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
|
---|
| 145 | $2802B89E, $5F058808, $C60CD9B2, $B10BE924, $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,
|
---|
| 146 | $76DC4190, $1DB7106, $98D220BC, $EFD5102A, $71B18589, $6B6B51F, $9FBFE4A5, $E8B8D433,
|
---|
| 147 | $7807C9A2, $F00F934, $9609A88E, $E10E9818, $7F6A0DBB, $86D3D2D, $91646C97, $E6635C01,
|
---|
| 148 | $6B6B51F4, $1C6C6162, $856530D8, $F262004E, $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
|
---|
| 149 | $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C, $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
|
---|
| 150 | $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2, $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
|
---|
| 151 | $4369E96A, $346ED9FC, $AD678846, $DA60B8D0, $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
|
---|
| 152 | $5005713C, $270241AA, $BE0B1010, $C90C2086, $5768B525, $206F85B3, $B966D409, $CE61E49F,
|
---|
| 153 | $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4, $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
|
---|
| 154 | $EDB88320, $9ABFB3B6, $3B6E20C, $74B1D29A, $EAD54739, $9DD277AF, $4DB2615, $73DC1683,
|
---|
| 155 | $E3630B12, $94643B84, $D6D6A3E, $7A6A5AA8, $E40ECF0B, $9309FF9D, $A00AE27, $7D079EB1,
|
---|
| 156 | $F00F9344, $8708A3D2, $1E01F268, $6906C2FE, $F762575D, $806567CB, $196C3671, $6E6B06E7,
|
---|
| 157 | $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC, $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
|
---|
| 158 | $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252, $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
|
---|
| 159 | $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60, $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
|
---|
| 160 | $CB61B38C, $BC66831A, $256FD2A0, $5268E236, $CC0C7795, $BB0B4703, $220216B9, $5505262F,
|
---|
| 161 | $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04, $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,
|
---|
| 162 | $9B64C2B0, $EC63F226, $756AA39C, $26D930A, $9C0906A9, $EB0E363F, $72076785, $5005713,
|
---|
| 163 | $95BF4A82, $E2B87A14, $7BB12BAE, $CB61B38, $92D28E9B, $E5D5BE0D, $7CDCEFB7, $BDBDF21,
|
---|
| 164 | $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E, $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
|
---|
| 165 | $88085AE6, $FF0F6A70, $66063BCA, $11010B5C, $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
|
---|
| 166 | $A00AE278, $D70DD2EE, $4E048354, $3903B3C2, $A7672661, $D06016F7, $4969474D, $3E6E77DB,
|
---|
| 167 | $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0, $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
|
---|
| 168 | $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6, $BAD03605, $CDD70693, $54DE5729, $23D967BF,
|
---|
| 169 | $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94, $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);
|
---|
| 170 |
|
---|
| 171 | {Properties assigned to BaseFont}
|
---|
| 172 | BaseFontSize = 8;
|
---|
| 173 | BaseFontName = 'MS Sans Serif';
|
---|
| 174 | var
|
---|
| 175 | FBaseFont: TFont;
|
---|
| 176 | type
|
---|
| 177 | EFMDateTimeError = class(Exception);
|
---|
| 178 |
|
---|
| 179 | {TFontControl is an artifact used for font resizing. Do not add virtual
|
---|
| 180 | methods or class variables to it!}
|
---|
| 181 | TFontControl = class(TControl)
|
---|
| 182 | public
|
---|
| 183 | property Font;
|
---|
| 184 | property ParentFont;
|
---|
| 185 | end;
|
---|
| 186 |
|
---|
| 187 | { Date/Time functions }
|
---|
| 188 |
|
---|
| 189 | function DateTimeToFMDateTime(ADateTime: TDateTime): TFMDateTime;
|
---|
| 190 | { converts a Delphi date/time type to a Fileman date/time (type double) }
|
---|
| 191 | var
|
---|
| 192 | y, m, d, h, n, s, l: Word;
|
---|
| 193 | DatePart,TimePart: Integer;
|
---|
| 194 | begin
|
---|
| 195 | DecodeDate(ADateTime, y, m, d);
|
---|
| 196 | DecodeTime(ADateTime, h, n, s, l);
|
---|
| 197 | DatePart := ((y-1700)*10000) + (m*100) + d;
|
---|
| 198 | TimePart := (h*10000) + (n*100) + s;
|
---|
| 199 | Result := DatePart + (TimePart / 1000000);
|
---|
| 200 | end;
|
---|
| 201 |
|
---|
| 202 | function FMDateTimeToDateTime(ADateTime: TFMDateTime): TDateTime;
|
---|
| 203 | { converts a Fileman date/time (type double) to a Delphi date/time }
|
---|
| 204 | var
|
---|
| 205 | ADate, ATime: TDateTime;
|
---|
| 206 | DatePart, TimePart: string;
|
---|
| 207 | begin
|
---|
| 208 | DatePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 1);
|
---|
| 209 | TimePart := Piece(FloatToStrF(ADateTime, ffFixed, 14, 6), '.', 2) + '000000';
|
---|
| 210 | if Length(DatePart) <> 7 then raise EFMDateTimeError.Create('Invalid Fileman Date');
|
---|
| 211 | if Copy(TimePart, 1, 2) = '24' then TimePart := '23595959';
|
---|
| 212 | ADate := EncodeDate(StrToInt(Copy(DatePart, 1, 3)) + 1700,
|
---|
| 213 | StrToInt(Copy(DatePart, 4, 2)),
|
---|
| 214 | StrToInt(Copy(DatePart, 6, 2)));
|
---|
| 215 | ATime := EncodeTime(StrToInt(Copy(TimePart, 1, 2)),
|
---|
| 216 | StrToInt(Copy(TimePart, 3, 2)),
|
---|
| 217 | StrToInt(Copy(TimePart, 5, 2)), 0);
|
---|
| 218 | Result := ADate + ATime;
|
---|
| 219 | end;
|
---|
| 220 |
|
---|
| 221 | function FMDateTimeOffsetBy(ADateTime: TFMDateTime; DaysDiff: Integer): TFMDateTime;
|
---|
| 222 | { adds / subtracts days from a Fileman date/time and returns the offset Fileman date/time }
|
---|
| 223 | var
|
---|
| 224 | Julian: TDateTime;
|
---|
| 225 | begin
|
---|
| 226 | Julian := FMDateTimeToDateTime(ADateTime);
|
---|
| 227 | Result := DateTimeToFMDateTime(Julian + DaysDiff);
|
---|
| 228 | end;
|
---|
| 229 |
|
---|
| 230 | function FormatFMDateTime(AFormat: string; ADateTime: TFMDateTime): string;
|
---|
| 231 | { formats a Fileman Date/Time using (mostly) the same format string as Delphi FormatDateTime }
|
---|
| 232 | var
|
---|
| 233 | x: string;
|
---|
| 234 | y, m, d, h, n, s: Integer;
|
---|
| 235 |
|
---|
| 236 | function TrimFormatCount: Integer;
|
---|
| 237 | { delete repeating characters and count how many were deleted }
|
---|
| 238 | var
|
---|
| 239 | c: Char;
|
---|
| 240 | begin
|
---|
| 241 | Result := 0;
|
---|
| 242 | c := AFormat[1];
|
---|
| 243 | repeat
|
---|
| 244 | Delete(AFormat, 1, 1);
|
---|
| 245 | Inc(Result);
|
---|
| 246 | until CharAt(AFormat, 1) <> c;
|
---|
| 247 | end;
|
---|
| 248 |
|
---|
| 249 | begin {FormatFMDateTime}
|
---|
| 250 | Result := '';
|
---|
| 251 | if not (ADateTime > 0) then Exit;
|
---|
| 252 | x := FloatToStrF(ADateTime, ffFixed, 15, 6) + '0000000';
|
---|
| 253 | y := StrToIntDef(Copy(x, 1, 3), 0) + 1700;
|
---|
| 254 | m := StrToIntDef(Copy(x, 4, 2), 0);
|
---|
| 255 | d := StrToIntDef(Copy(x, 6, 2), 0);
|
---|
| 256 | h := StrToIntDef(Copy(x, 9, 2), 0);
|
---|
| 257 | n := StrToIntDef(Copy(x, 11, 2), 0);
|
---|
| 258 | s := StrToIntDef(Copy(x, 13, 2), 0);
|
---|
| 259 | while Length(AFormat) > 0 do
|
---|
| 260 | case UpCase(AFormat[1]) of
|
---|
| 261 | '"': begin // literal
|
---|
| 262 | Delete(AFormat, 1, 1);
|
---|
| 263 | while not (CharAt(AFormat, 1) in [#0, '"']) do
|
---|
| 264 | begin
|
---|
| 265 | Result := Result + AFormat[1];
|
---|
| 266 | Delete(AFormat, 1, 1);
|
---|
| 267 | end;
|
---|
| 268 | if CharAt(AFormat, 1) = '"' then Delete(AFormat, 1, 1);
|
---|
| 269 | end;
|
---|
| 270 | 'D': case TrimFormatCount of // day/date
|
---|
| 271 | 1: if d > 0 then Result := Result + IntToStr(d);
|
---|
| 272 | 2: if d > 0 then Result := Result + FormatFloat('00', d);
|
---|
| 273 | end;
|
---|
| 274 | 'H': case TrimFormatCount of // hour
|
---|
| 275 | 1: Result := Result + IntToStr(h);
|
---|
| 276 | 2: Result := Result + FormatFloat('00', h);
|
---|
| 277 | end;
|
---|
| 278 | 'M': case TrimFormatCount of // month
|
---|
| 279 | 1: if m > 0 then Result := Result + IntToStr(m);
|
---|
| 280 | 2: if m > 0 then Result := Result + FormatFloat('00', m);
|
---|
| 281 | 3: if m in [1..12] then Result := Result + MONTH_NAMES_SHORT[m];
|
---|
| 282 | 4: if m in [1..12] then Result := Result + MONTH_NAMES_LONG[m];
|
---|
| 283 | end;
|
---|
| 284 | 'N': case TrimFormatCount of // minute
|
---|
| 285 | 1: Result := Result + IntToStr(n);
|
---|
| 286 | 2: Result := Result + FormatFloat('00', n);
|
---|
| 287 | end;
|
---|
| 288 | 'S': case TrimFormatCount of // second
|
---|
| 289 | 1: Result := Result + IntToStr(s);
|
---|
| 290 | 2: Result := Result + FormatFloat('00', s);
|
---|
| 291 | end;
|
---|
| 292 | 'Y': case TrimFormatCount of // year
|
---|
| 293 | 2: if y > 0 then Result := Result + Copy(IntToStr(y), 3, 2);
|
---|
| 294 | 4: if y > 0 then Result := Result + IntToStr(y);
|
---|
| 295 | end;
|
---|
| 296 | else begin // other
|
---|
| 297 | Result := Result + AFormat[1];
|
---|
| 298 | Delete(AFormat, 1, 1);
|
---|
| 299 | end;
|
---|
| 300 | end; {case}
|
---|
| 301 | end; {FormatFMDateTime}
|
---|
| 302 |
|
---|
| 303 | function FormatFMDateTimeStr(const AFormat, ADateTime: string): string;
|
---|
| 304 | var
|
---|
| 305 | FMDateTime: TFMDateTime;
|
---|
| 306 | begin
|
---|
| 307 | Result := ADateTime;
|
---|
| 308 | if IsFMDateTime(ADateTime) then
|
---|
| 309 | begin
|
---|
| 310 | FMDateTime := MakeFMDateTime(ADateTime);
|
---|
| 311 | Result := FormatFMDateTime(AFormat, FMDateTime);
|
---|
| 312 | end;
|
---|
| 313 | end;
|
---|
| 314 |
|
---|
| 315 | function IsFMDateTime(x: string): Boolean;
|
---|
| 316 | var
|
---|
| 317 | i: Integer;
|
---|
| 318 | begin
|
---|
| 319 | Result := False;
|
---|
| 320 | if Length(x) < 7 then Exit;
|
---|
| 321 | for i := 1 to 7 do if not (x[i] in ['0'..'9']) then Exit;
|
---|
| 322 | if (Length(x) > 7) and (x[8] <> '.') then Exit;
|
---|
| 323 | if (Length(x) > 8) and not (x[9] in ['0'..'9']) then Exit;
|
---|
| 324 | Result := True;
|
---|
| 325 | end;
|
---|
| 326 |
|
---|
| 327 | function MakeFMDateTime(const AString: string): TFMDateTime;
|
---|
| 328 | begin
|
---|
| 329 | Result := -1;
|
---|
| 330 | if (Length(AString) > 0) and IsFMDateTime(AString) then Result := StrToFloat(AString);
|
---|
| 331 | end;
|
---|
| 332 |
|
---|
| 333 | procedure SetListFMDateTime(AFormat: string; AList: TStringList; ADelim: Char;
|
---|
| 334 | PieceNum: Integer; KeepBad: boolean = FALSE);
|
---|
| 335 | var
|
---|
| 336 | i: Integer;
|
---|
| 337 | s, x, x1: string;
|
---|
| 338 |
|
---|
| 339 | begin
|
---|
| 340 | for i := 0 to AList.Count - 1 do
|
---|
| 341 | begin
|
---|
| 342 | s := AList[i];
|
---|
| 343 | x := Piece(s, ADelim, PieceNum);
|
---|
| 344 | if Length(x) > 0 then
|
---|
| 345 | begin
|
---|
| 346 | x1 := FormatFMDateTime(AFormat, MakeFMDateTime(x));
|
---|
| 347 | if(x1 <> '') or (not KeepBad) then
|
---|
| 348 | x := x1;
|
---|
| 349 | end;
|
---|
| 350 | SetPiece(s, ADelim, PieceNum, x);
|
---|
| 351 | AList[i] := s;
|
---|
| 352 | end;
|
---|
| 353 | end;
|
---|
| 354 |
|
---|
| 355 | { Numeric functions }
|
---|
| 356 |
|
---|
| 357 | function HigherOf(i, j: Integer): Integer;
|
---|
| 358 | { returns the greater of two integers }
|
---|
| 359 | begin
|
---|
| 360 | Result := i;
|
---|
| 361 | if j > i then Result := j;
|
---|
| 362 | end;
|
---|
| 363 |
|
---|
| 364 | function LowerOf(i, j: Integer): Integer;
|
---|
| 365 | { returns the lesser of two integers }
|
---|
| 366 | begin
|
---|
| 367 | Result := i;
|
---|
| 368 | if j < i then Result := j;
|
---|
| 369 | end;
|
---|
| 370 |
|
---|
| 371 | function StrToFloatDef(const S: string; ADefault: Extended): Extended;
|
---|
| 372 | begin
|
---|
| 373 | if not TextToFloat(PChar(S), Result, fvExtended) then
|
---|
| 374 | Result := ADefault;
|
---|
| 375 | end;
|
---|
| 376 |
|
---|
| 377 | { String functions }
|
---|
| 378 |
|
---|
| 379 | function CharAt(const x: string; APos: Integer): Char;
|
---|
| 380 | { returns a character at a given position in a string or the null character if past the end }
|
---|
| 381 | begin
|
---|
| 382 | if Length(x) < APos then Result := #0 else Result := x[APos];
|
---|
| 383 | end;
|
---|
| 384 |
|
---|
| 385 | function ContainsAlpha(const x: string): Boolean;
|
---|
| 386 | { returns true if the string contains any alpha characters }
|
---|
| 387 | var
|
---|
| 388 | i: Integer;
|
---|
| 389 | begin
|
---|
| 390 | Result := False;
|
---|
| 391 | for i := 1 to Length(x) do if x[i] in ['A'..'Z','a'..'z'] then
|
---|
| 392 | begin
|
---|
| 393 | Result := True;
|
---|
| 394 | break;
|
---|
| 395 | end;
|
---|
| 396 | end;
|
---|
| 397 |
|
---|
| 398 | function ContainsVisibleChar(const x: string): Boolean;
|
---|
| 399 | { returns true if the string contains any printable characters }
|
---|
| 400 | var
|
---|
| 401 | i: Integer;
|
---|
| 402 | begin
|
---|
| 403 | Result := False;
|
---|
| 404 | for i := 1 to Length(x) do if x[i] in ['!'..'~'] then // ordinal values 33..126
|
---|
| 405 | begin
|
---|
| 406 | Result := True;
|
---|
| 407 | break;
|
---|
| 408 | end;
|
---|
| 409 | end;
|
---|
| 410 |
|
---|
| 411 | function ConvertSpecialStrings(const x: string): string;
|
---|
| 412 | var i : Integer;
|
---|
| 413 | begin
|
---|
| 414 | for i := 0 to Length(SearchChars)-1 do
|
---|
| 415 | begin
|
---|
| 416 | Result := StringReplace(Result,SearchChars[i], ReplaceChars[i],[rfReplaceAll]);
|
---|
| 417 | end;
|
---|
| 418 | end;
|
---|
| 419 |
|
---|
| 420 | function UpdateCrc32(Value: DWORD; var Buffer: array of Byte; Count: Integer): DWORD;
|
---|
| 421 | var
|
---|
| 422 | i: integer;
|
---|
| 423 | begin
|
---|
| 424 | Result:=Value;
|
---|
| 425 | for i := 0 to Pred(Count) do
|
---|
| 426 | Result := ((Result shr 8) and $00FFFFFF) xor
|
---|
| 427 | CRC32_TABLE[(Result xor Buffer[i]) and $000000FF];
|
---|
| 428 | end;
|
---|
| 429 |
|
---|
| 430 | function CRCForFile(AFileName: string): DWORD;
|
---|
| 431 | const
|
---|
| 432 | BUF_SIZE = 16383;
|
---|
| 433 | type
|
---|
| 434 | TBuffer = array[0..BUF_SIZE] of Byte;
|
---|
| 435 | var
|
---|
| 436 | Buffer: Pointer;
|
---|
| 437 | AHandle, BytesRead: Integer;
|
---|
| 438 | begin
|
---|
| 439 | Result:=$FFFFFFFF;
|
---|
| 440 | GetMem(Buffer, BUF_SIZE);
|
---|
| 441 | AHandle := FileOpen(AFileName, fmShareDenyWrite);
|
---|
| 442 | repeat
|
---|
| 443 | BytesRead := FileRead(AHandle, Buffer^, BUF_SIZE);
|
---|
| 444 | Result := UpdateCrc32(Result, TBuffer(Buffer^), BytesRead);
|
---|
| 445 | until BytesRead <> BUF_SIZE;
|
---|
| 446 | FileClose(AHandle);
|
---|
| 447 | FreeMem(Buffer);
|
---|
| 448 | Result := not Result;
|
---|
| 449 | end;
|
---|
| 450 |
|
---|
| 451 | function CRCForStrings(AStringList: TStrings): DWORD;
|
---|
| 452 | { returns a cyclic redundancy check for a list of strings }
|
---|
| 453 | var
|
---|
| 454 | i, j: Integer;
|
---|
| 455 | begin
|
---|
| 456 | Result:=$FFFFFFFF;
|
---|
| 457 | for i := 0 to AStringList.Count - 1 do
|
---|
| 458 | for j := 1 to Length(AStringList[i]) do
|
---|
| 459 | Result:=((Result shr 8) and $00FFFFFF) xor
|
---|
| 460 | CRC32_TABLE[(Result xor Ord(AStringList[i][j])) and $000000FF];
|
---|
| 461 | end;
|
---|
| 462 |
|
---|
| 463 | function FilteredString(const x: string; ATabWidth: Integer = 8): string;
|
---|
| 464 | var
|
---|
| 465 | i, j: Integer;
|
---|
| 466 | begin
|
---|
| 467 | Result := '';
|
---|
| 468 | for i := 1 to Length(x) do
|
---|
| 469 | case x[i] of
|
---|
| 470 | #9: for j := 1 to (ATabWidth - (Length(Result) mod ATabWidth)) do
|
---|
| 471 | Result := Result + ' ';
|
---|
| 472 | #32..#127: Result := Result + x[i];
|
---|
| 473 | #128..#159: Result := Result + '?';
|
---|
| 474 | #10,#13,#160: Result := Result + ' ';
|
---|
| 475 | #161..#255: Result := Result + x[i];
|
---|
| 476 | end;
|
---|
| 477 | if Copy(Result, Length(Result), 1) = ' ' then Result := TrimRight(Result) + ' ';
|
---|
| 478 | end;
|
---|
| 479 |
|
---|
| 480 | procedure ExpandTabsFilter(AList: TStrings; ATabWidth: Integer);
|
---|
| 481 | var
|
---|
| 482 | i, j, k: Integer;
|
---|
| 483 | x, y: string;
|
---|
| 484 | begin
|
---|
| 485 | with AList do for i := 0 to Count - 1 do
|
---|
| 486 | begin
|
---|
| 487 | x := Strings[i];
|
---|
| 488 | y := '';
|
---|
| 489 | for j := 1 to Length(x) do
|
---|
| 490 | case x[j] of
|
---|
| 491 | #9: for k := 1 to (ATabWidth - (Length(y) mod ATabWidth)) do y := y + ' ';
|
---|
| 492 | #32..#127: y := y + x[j];
|
---|
| 493 | #128..#159: y := y + '?';
|
---|
| 494 | #160: y := y + ' ';
|
---|
| 495 | #161..#255: y := y + x[j];
|
---|
| 496 | end;
|
---|
| 497 | if Copy(y, Length(y), 1) = ' ' then y := TrimRight(y) + ' ';
|
---|
| 498 | Strings[i] := y;
|
---|
| 499 | //Strings[i] := TrimRight(y) + ' ';
|
---|
| 500 | end;
|
---|
| 501 | end;
|
---|
| 502 |
|
---|
| 503 | function ExtractInteger(x: string): Integer;
|
---|
| 504 | { strips leading & trailing alphas to return an integer }
|
---|
| 505 | var
|
---|
| 506 | i: Integer;
|
---|
| 507 | begin
|
---|
| 508 | while (Length(x) > 0) and not (x[1] in ['0'..'9']) do Delete(x, 1, 1);
|
---|
| 509 | for i := 1 to Length(x) do if not (x[i] in ['0'..'9']) then break;
|
---|
| 510 | Result := StrToIntDef(Copy(x, 1, i - 1), 0);
|
---|
| 511 | end;
|
---|
| 512 |
|
---|
| 513 | function ExtractFloat(x: string): Extended;
|
---|
| 514 | { strips leading & trailing alphas to return a float }
|
---|
| 515 | var
|
---|
| 516 | i: Integer;
|
---|
| 517 | begin
|
---|
| 518 | while (Length(x) > 0) and not (x[1] in ['0'..'9', '.']) do Delete(x, 1, 1);
|
---|
| 519 | for i := 1 to Length(x) do if not (x[i] in ['0'..'9','.']) then break;
|
---|
| 520 | Result := StrToFloatDef(Copy(x, 1, i - 1), 0);
|
---|
| 521 | end;
|
---|
| 522 |
|
---|
| 523 | function ExtractDefault(Src: TStrings; const Section: string): string;
|
---|
| 524 | var
|
---|
| 525 | i: Integer;
|
---|
| 526 | begin
|
---|
| 527 | Result := '';
|
---|
| 528 | i := -1;
|
---|
| 529 | repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
|
---|
| 530 | Inc(i);
|
---|
| 531 | if (i < Src.Count) and (Src[i][1] <> '~') then repeat
|
---|
| 532 | if Src[i][1] = 'd' then Result := Copy(Src[i], 2, MaxInt);
|
---|
| 533 | Inc(i);
|
---|
| 534 | until (i = Src.Count) or (Src[i][1] = '~') or (Length(Result) > 0);
|
---|
| 535 | end;
|
---|
| 536 |
|
---|
| 537 | procedure ExtractItems(Dest, Src: TStrings; const Section: string);
|
---|
| 538 | var
|
---|
| 539 | i: Integer;
|
---|
| 540 | begin
|
---|
| 541 | i := -1;
|
---|
| 542 | repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
|
---|
| 543 | Inc(i);
|
---|
| 544 | if (i < Src.Count) and (Src[i][1] <> '~') then repeat
|
---|
| 545 | if Src[i][1] = 'i' then Dest.Add(Copy(Src[i], 2, MaxInt));
|
---|
| 546 | Inc(i);
|
---|
| 547 | until (i = Src.Count) or (Src[i][1] = '~');
|
---|
| 548 | end;
|
---|
| 549 |
|
---|
| 550 | procedure ExtractText(Dest, Src: TStrings; const Section: string);
|
---|
| 551 | var
|
---|
| 552 | i: Integer;
|
---|
| 553 | begin
|
---|
| 554 | i := -1;
|
---|
| 555 | repeat Inc(i) until (i = Src.Count) or (Src[i] = '~' + Section);
|
---|
| 556 | Inc(i);
|
---|
| 557 | if (i < Src.Count) and (Src[i][1] <> '~') then repeat
|
---|
| 558 | if Src[i][1] = 't' then Dest.Add(Copy(Src[i], 2, MaxInt));
|
---|
| 559 | Inc(i);
|
---|
| 560 | until (i = Src.Count) or (Src[i][1] = '~');
|
---|
| 561 | end;
|
---|
| 562 |
|
---|
| 563 | procedure InvertStringList(AList: TStringList);
|
---|
| 564 | var
|
---|
| 565 | i: Integer;
|
---|
| 566 | begin
|
---|
| 567 | with AList do for i := 0 to ((Count div 2) - 1) do Exchange(i, Count - i - 1);
|
---|
| 568 | end;
|
---|
| 569 |
|
---|
| 570 | function MixedCase(const x: string): string;
|
---|
| 571 | var
|
---|
| 572 | i: integer;
|
---|
| 573 | begin
|
---|
| 574 | Result := x;
|
---|
| 575 | for i := 2 to Length(x) do
|
---|
| 576 | if (not (x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
|
---|
| 577 | // save line if (not (x[i-1] in [' ','''',',','-','.','/','^'])) and (x[i] in ['A'..'Z'])
|
---|
| 578 | then Result[i] := Chr(Ord(x[i]) + 32)
|
---|
| 579 | else if ((x[i-1] in [' ',',','-','.','/','^'])) and (x[i] in ['a'..'z'])
|
---|
| 580 | then Result[i] := Chr(Ord(x[i]) - 32);
|
---|
| 581 | //Call added to satisfy the need for special string handling(Roman Numerals II-XI) GRE-06/02
|
---|
| 582 | Result := ConvertSpecialStrings(x);
|
---|
| 583 | end;
|
---|
| 584 |
|
---|
| 585 | procedure MixedCaseList(AList: TStrings);
|
---|
| 586 | var
|
---|
| 587 | i: integer;
|
---|
| 588 | begin
|
---|
| 589 | for i := 0 to (AList.Count - 1) do AList[i] := MixedCase(AList[i]);
|
---|
| 590 | end;
|
---|
| 591 |
|
---|
| 592 | procedure MixedCaseByPiece(AList: TStrings; ADelim: Char; PieceNum: Integer);
|
---|
| 593 | var
|
---|
| 594 | i: Integer;
|
---|
| 595 | x, p: string;
|
---|
| 596 | begin
|
---|
| 597 | for i := 0 to (AList.Count - 1) do
|
---|
| 598 | begin
|
---|
| 599 | x := AList[i];
|
---|
| 600 | p := MixedCase(Piece(x, ADelim, PieceNum));
|
---|
| 601 | SetPiece(x, ADelim, PieceNum, p);
|
---|
| 602 | AList[i] := x;
|
---|
| 603 | end;
|
---|
| 604 | end;
|
---|
| 605 |
|
---|
| 606 | function Piece(const S: string; Delim: char; PieceNum: Integer): string;
|
---|
| 607 | { returns the Nth piece (PieceNum) of a string delimited by Delim }
|
---|
| 608 | var
|
---|
| 609 | i: Integer;
|
---|
| 610 | Strt, Next: PChar;
|
---|
| 611 | begin
|
---|
| 612 | i := 1;
|
---|
| 613 | Strt := PChar(S);
|
---|
| 614 | Next := StrScan(Strt, Delim);
|
---|
| 615 | while (i < PieceNum) and (Next <> nil) do
|
---|
| 616 | begin
|
---|
| 617 | Inc(i);
|
---|
| 618 | Strt := Next + 1;
|
---|
| 619 | Next := StrScan(Strt, Delim);
|
---|
| 620 | end;
|
---|
| 621 | if Next = nil then Next := StrEnd(Strt);
|
---|
| 622 | if i < PieceNum then Result := '' else SetString(Result, Strt, Next - Strt);
|
---|
| 623 | end;
|
---|
| 624 |
|
---|
| 625 | function Pieces(const S: string; Delim: char; FirstNum, LastNum: Integer): string;
|
---|
| 626 | { returns several contiguous pieces }
|
---|
| 627 | var
|
---|
| 628 | PieceNum: Integer;
|
---|
| 629 | begin
|
---|
| 630 | Result := '';
|
---|
| 631 | for PieceNum := FirstNum to LastNum do Result := Result + Piece(S, Delim, PieceNum) + Delim;
|
---|
| 632 | if Length(Result) > 0 then Delete(Result, Length(Result), 1);
|
---|
| 633 | end;
|
---|
| 634 |
|
---|
| 635 | function ComparePieces(P1, P2: string; Pieces: array of integer; Delim:
|
---|
| 636 | char = '^'; CaseInsensitive: boolean = FALSE): integer;
|
---|
| 637 | var
|
---|
| 638 | i: integer;
|
---|
| 639 |
|
---|
| 640 | begin
|
---|
| 641 | i := 0;
|
---|
| 642 | Result := 0;
|
---|
| 643 | while i <= high(Pieces) do
|
---|
| 644 | begin
|
---|
| 645 | if(CaseInsensitive) then
|
---|
| 646 | Result := CompareText(Piece(P1, Delim, Pieces[i]),
|
---|
| 647 | Piece(P2, Delim, Pieces[i]))
|
---|
| 648 | else
|
---|
| 649 | Result := CompareStr(Piece(P1, Delim, Pieces[i]),
|
---|
| 650 | Piece(P2, Delim, Pieces[i]));
|
---|
| 651 | if(Result = 0) then
|
---|
| 652 | inc(i)
|
---|
| 653 | else
|
---|
| 654 | break;
|
---|
| 655 | end;
|
---|
| 656 | end;
|
---|
| 657 |
|
---|
| 658 | procedure PiecesToList(x: string; ADelim: Char; AList: TStrings);
|
---|
| 659 | { adds each piece to a TStrings list, the list is cleared first }
|
---|
| 660 | var
|
---|
| 661 | APiece: string;
|
---|
| 662 | begin
|
---|
| 663 | AList.Clear;
|
---|
| 664 | while Length(x) > 0 do
|
---|
| 665 | begin
|
---|
| 666 | APiece := Piece(x, ADelim, 1);
|
---|
| 667 | AList.Add(APiece);
|
---|
| 668 | Delete(x, 1, Length(APiece) + 1);
|
---|
| 669 | end;
|
---|
| 670 | end;
|
---|
| 671 |
|
---|
| 672 | function ReverseStr(const x: string): string;
|
---|
| 673 | var
|
---|
| 674 | i, j: Integer;
|
---|
| 675 | begin
|
---|
| 676 | SetString(Result, PChar(x), Length(x));
|
---|
| 677 | i := 0;
|
---|
| 678 | for j := Length(x) downto 1 do
|
---|
| 679 | begin
|
---|
| 680 | Inc(i);
|
---|
| 681 | Result[i] := x[j];
|
---|
| 682 | end;
|
---|
| 683 | end;
|
---|
| 684 |
|
---|
| 685 | procedure SetPiece(var x: string; Delim: Char; PieceNum: Integer; const NewPiece: string);
|
---|
| 686 | { sets the Nth piece (PieceNum) of a string to NewPiece, adding delimiters as necessary }
|
---|
| 687 | var
|
---|
| 688 | i: Integer;
|
---|
| 689 | Strt, Next: PChar;
|
---|
| 690 | begin
|
---|
| 691 | i := 1;
|
---|
| 692 | Strt := PChar(x);
|
---|
| 693 | Next := StrScan(Strt, Delim);
|
---|
| 694 | while (i < PieceNum) and (Next <> nil) do
|
---|
| 695 | begin
|
---|
| 696 | Inc(i);
|
---|
| 697 | Strt := Next + 1;
|
---|
| 698 | Next := StrScan(Strt, Delim);
|
---|
| 699 | end;
|
---|
| 700 | if Next = nil then Next := StrEnd(Strt);
|
---|
| 701 | if i < PieceNum
|
---|
| 702 | then x := x + StringOfChar(Delim, PieceNum - i) + NewPiece
|
---|
| 703 | else x := Copy(x, 1, Strt - PChar(x)) + NewPiece + StrPas(Next);
|
---|
| 704 | end;
|
---|
| 705 |
|
---|
| 706 | procedure SetPieces(var x: string; Delim: Char; Pieces: Array of Integer;
|
---|
| 707 | FromString: string);
|
---|
| 708 | var
|
---|
| 709 | i: integer;
|
---|
| 710 |
|
---|
| 711 | begin
|
---|
| 712 | for i := low(Pieces) to high(Pieces) do
|
---|
| 713 | SetPiece(x, Delim, Pieces[i], Piece(FromString, Delim, Pieces[i]));
|
---|
| 714 | end;
|
---|
| 715 |
|
---|
| 716 | procedure SortByPiece(AList: TStringList; ADelim: Char; PieceNum: Integer);
|
---|
| 717 | var
|
---|
| 718 | i: integer;
|
---|
| 719 | begin
|
---|
| 720 | for i := 0 to AList.Count - 1 do
|
---|
| 721 | AList[i] := Piece(AList[i], ADelim, PieceNum) + ADelim + AList[i];
|
---|
| 722 | AList.Sort;
|
---|
| 723 | for i := 0 to AList.Count - 1 do
|
---|
| 724 | AList[i] := Copy(AList[i], Pos(ADelim, AList[i]) + 1, MaxInt);
|
---|
| 725 | end;
|
---|
| 726 |
|
---|
| 727 | function DelimCount(const Str, Delim: string): integer;
|
---|
| 728 | var
|
---|
| 729 | i, dlen, slen: integer;
|
---|
| 730 |
|
---|
| 731 | begin
|
---|
| 732 | Result := 0;
|
---|
| 733 | i := 1;
|
---|
| 734 | dlen := length(Delim);
|
---|
| 735 | slen := length(Str) - dlen + 1;
|
---|
| 736 | while(i <= slen) do
|
---|
| 737 | begin
|
---|
| 738 | if(copy(Str,i,dlen) = Delim) then
|
---|
| 739 | begin
|
---|
| 740 | inc(Result);
|
---|
| 741 | inc(i,dlen);
|
---|
| 742 | end
|
---|
| 743 | else
|
---|
| 744 | inc(i);
|
---|
| 745 | end;
|
---|
| 746 | end;
|
---|
| 747 |
|
---|
| 748 | type
|
---|
| 749 | TREStrings = class(TStrings)
|
---|
| 750 | protected
|
---|
| 751 | FPlainText: Boolean;
|
---|
| 752 | public
|
---|
| 753 | property PlainText: Boolean read FPlainText write FPlainText;
|
---|
| 754 | end;
|
---|
| 755 |
|
---|
| 756 | type
|
---|
| 757 | QuickCopyError = class(Exception);
|
---|
| 758 |
|
---|
| 759 | procedure QuickCopy(AFrom, ATo: TObject);
|
---|
| 760 | var
|
---|
| 761 | ms: TMemoryStream;
|
---|
| 762 | idx: integer;
|
---|
| 763 | str: array[0..1] of TStrings;
|
---|
| 764 | fix: array[0..1] of boolean;
|
---|
| 765 |
|
---|
| 766 | procedure GetStrings(obj: TObject);
|
---|
| 767 | begin
|
---|
| 768 | if (CompareText(obj.ClassName, 'TRichEditStrings') = 0) then
|
---|
| 769 | raise QuickCopyError.Create('You must pass the TRichEdit object into QuickCopy, NOT it''s Lines property.');
|
---|
| 770 | if obj is TStrings then
|
---|
| 771 | str[idx] := TStrings(obj)
|
---|
| 772 | else
|
---|
| 773 | if obj is TMemo then
|
---|
| 774 | str[idx] := TMemo(obj).Lines
|
---|
| 775 | else
|
---|
| 776 | if obj is TORListBox then
|
---|
| 777 | str[idx] := TORListBox(obj).Items
|
---|
| 778 | else
|
---|
| 779 | if obj is TListBox then
|
---|
| 780 | str[idx] := TListBox(obj).Items
|
---|
| 781 | else
|
---|
| 782 | if obj is TRichEdit then
|
---|
| 783 | begin
|
---|
| 784 | with TRichEdit(obj) do
|
---|
| 785 | begin
|
---|
| 786 | str[idx] := Lines;
|
---|
| 787 | if not PlainText then
|
---|
| 788 | begin
|
---|
| 789 | fix[idx] := TRUE;
|
---|
| 790 | PlainText := TRUE;
|
---|
| 791 | end;
|
---|
| 792 | end;
|
---|
| 793 | end
|
---|
| 794 | else
|
---|
| 795 | raise QuickCopyError.Create('Unsupported object type (' + obj.ClassName +
|
---|
| 796 | ') passed into QuickCopy.');
|
---|
| 797 | inc(idx);
|
---|
| 798 | end;
|
---|
| 799 |
|
---|
| 800 |
|
---|
| 801 | begin
|
---|
| 802 | fix[0] := FALSE;
|
---|
| 803 | fix[1] := FALSE;
|
---|
| 804 | idx := 0;
|
---|
| 805 | GetStrings(AFrom);
|
---|
| 806 | GetStrings(ATo);
|
---|
| 807 | ms := TMemoryStream.Create;
|
---|
| 808 | try
|
---|
| 809 | str[0].SaveToStream(ms);
|
---|
| 810 | ms.Seek(0, soFromBeginning);
|
---|
| 811 | str[1].LoadFromStream(ms);
|
---|
| 812 | finally
|
---|
| 813 | ms.Free;
|
---|
| 814 | end;
|
---|
| 815 | if fix[0] then TRichEdit(AFrom).PlainText := FALSE;
|
---|
| 816 | if fix[1] then TRichEdit(ATo).PlainText := FALSE;
|
---|
| 817 | end;
|
---|
| 818 |
|
---|
| 819 | function ValidFileName(const InitialFileName: string): string;
|
---|
| 820 | var
|
---|
| 821 | i: integer;
|
---|
| 822 |
|
---|
| 823 | begin
|
---|
| 824 | Result := InitialFileName;
|
---|
| 825 | i := 1;
|
---|
| 826 | while i <= length(Result) do
|
---|
| 827 | begin
|
---|
| 828 | if Result[i] in ['a'..'z','A'..'Z','0'..'9',#32] then
|
---|
| 829 | inc(i)
|
---|
| 830 | else
|
---|
| 831 | delete(Result,i,1);
|
---|
| 832 | end;
|
---|
| 833 | end;
|
---|
| 834 |
|
---|
| 835 | procedure LimitStringLength(var AList: TStringList; MaxLength: Integer);
|
---|
| 836 | var
|
---|
| 837 | i, SpacePos: Integer;
|
---|
| 838 | x: string;
|
---|
| 839 | NewList: TStringList;
|
---|
| 840 | begin
|
---|
| 841 | NewList := TStringList.Create;
|
---|
| 842 | try
|
---|
| 843 | for i := 0 to AList.Count - 1 do
|
---|
| 844 | begin
|
---|
| 845 | if Length(AList[i]) > MaxLength then
|
---|
| 846 | begin
|
---|
| 847 | x := AList[i];
|
---|
| 848 | while Length(x) > MaxLength do
|
---|
| 849 | begin
|
---|
| 850 | SpacePos := MaxLength;
|
---|
| 851 | // while SpacePos > 0 do {**REV**} removed after v11b
|
---|
| 852 | // if (x[SpacePos] <> ' ') then Dec(SpacePos); {**REV**} removed after v11b
|
---|
| 853 | while (x[SpacePos] <> ' ') and (SpacePos > 1) do Dec(SpacePos); {**REV**} {changed 0 to 1}
|
---|
| 854 | if SpacePos = 1 then SpacePos := MaxLength; {**REV**} {changed 0 to 1}
|
---|
| 855 | NewList.Add(Copy(x, 1, SpacePos )); // CQ PSI-05-040 change SpacePos-1 to SpacePos
|
---|
| 856 | Delete(x, 1, SpacePos);
|
---|
| 857 | end; {while Length(x)}
|
---|
| 858 | if Length(x) > 0 then NewList.Add(x);
|
---|
| 859 | end {then}
|
---|
| 860 | else NewList.Add(AList[i]);
|
---|
| 861 | end; {for i}
|
---|
| 862 | AList.Clear;
|
---|
| 863 | AList.Assign(NewList);
|
---|
| 864 | finally
|
---|
| 865 | NewList.Free;
|
---|
| 866 | end;
|
---|
| 867 | end;
|
---|
| 868 |
|
---|
| 869 | { Display functions }
|
---|
| 870 |
|
---|
| 871 | (*
|
---|
| 872 | procedure ClearControl(AControl: TControl);
|
---|
| 873 | { clears a control, removes text and listbox items }
|
---|
| 874 | begin
|
---|
| 875 | if AControl is TLabel then with TLabel(AControl) do Caption := ''
|
---|
| 876 | else if AControl is TButton then with TButton(AControl) do Caption := ''
|
---|
| 877 | else if AControl is TEdit then with TEdit(AControl) do Text := ''
|
---|
| 878 | else if AControl is TMemo then with TMemo(AControl) do Clear
|
---|
| 879 | else if AControl is TListBox then with TListBox(AControl) do Clear
|
---|
| 880 | else if AControl is TORComboBox then with TORComboBox(AControl) do
|
---|
| 881 | begin
|
---|
| 882 | MItems.Clear;
|
---|
| 883 | Text := '';
|
---|
| 884 | end
|
---|
| 885 | else if AControl is TComboBox then with TComboBox(AControl) do
|
---|
| 886 | begin
|
---|
| 887 | Clear;
|
---|
| 888 | Text := '';
|
---|
| 889 | end;
|
---|
| 890 | end;
|
---|
| 891 |
|
---|
| 892 | procedure ResetControl(AControl: TControl);
|
---|
| 893 | { clears text, deselects items, does not remove listbox or combobox items }
|
---|
| 894 | begin
|
---|
| 895 | if AControl is TLabel then with TLabel(AControl) do Caption := ''
|
---|
| 896 | else if AControl is TButton then with TButton(AControl) do Caption := ''
|
---|
| 897 | else if AControl is TEdit then with TEdit(AControl) do Text := ''
|
---|
| 898 | else if AControl is TMemo then with TMemo(AControl) do Clear
|
---|
| 899 | else if AControl is TListBox then with TListBox(AControl) do ItemIndex := -1
|
---|
| 900 | else if AControl is TORComboBox then with TORComboBox(AControl) do
|
---|
| 901 | begin
|
---|
| 902 | Text := '';
|
---|
| 903 | ItemIndex := -1;
|
---|
| 904 | end
|
---|
| 905 | else if AControl is TComboBox then with TComboBox(AControl) do
|
---|
| 906 | begin
|
---|
| 907 | Text := '';
|
---|
| 908 | ItemIndex := -1;
|
---|
| 909 | end;
|
---|
| 910 | end;
|
---|
| 911 | *)
|
---|
| 912 |
|
---|
| 913 | function InfoBox(const Text, Caption: string; Flags: Word): Integer;
|
---|
| 914 | { wrap the messagebox object in case we want to modify it later }
|
---|
| 915 | begin
|
---|
| 916 | Result := Application.MessageBox(PChar(Text), PChar(Caption), Flags or MB_TOPMOST);
|
---|
| 917 | end;
|
---|
| 918 |
|
---|
| 919 | procedure LimitEditWidth(AControl: TWinControl; NumChars: Integer);
|
---|
| 920 | { limits the editing area to be no more than N characters (also sets small left margin) }
|
---|
| 921 | const
|
---|
| 922 | LEFT_MARGIN = 4;
|
---|
| 923 | var
|
---|
| 924 | ARect: TRect;
|
---|
| 925 | AHandle: DWORD;
|
---|
| 926 | AWidth, i: Integer;
|
---|
| 927 | x: string;
|
---|
| 928 | begin
|
---|
| 929 | Inc(NumChars);
|
---|
| 930 | SetString(x, nil, NumChars);
|
---|
| 931 | for i := 1 to NumChars do x[i] := 'X';
|
---|
| 932 | with AControl do
|
---|
| 933 | begin
|
---|
| 934 | AHandle := 0;
|
---|
| 935 | if AControl is TEdit then AHandle := TEdit(AControl).Font.Handle;
|
---|
| 936 | if AControl is TMemo then AHandle := TMemo(AControl).Font.Handle;
|
---|
| 937 | if AControl is TRichEdit then AHandle := TRichEdit(AControl).Font.Handle;
|
---|
| 938 | if AHandle = 0 then Exit;
|
---|
| 939 | AWidth := TextWidthByFont(AHandle, x);
|
---|
| 940 | ARect := Rect(LEFT_MARGIN, 0, AWidth + LEFT_MARGIN, ClientHeight);
|
---|
| 941 | // set the editing rectangle to with with of NumChars
|
---|
| 942 | SendMessage(Handle, EM_SETRECT, 0, Longint(@ARect));
|
---|
| 943 | // turn on auto-scrolling for a rich edit
|
---|
| 944 | if AControl is TRichEdit
|
---|
| 945 | then SendMessage(Handle, EM_SETOPTIONS, ECOOP_OR, ECO_AUTOHSCROLL + ECO_AUTOVSCROLL);
|
---|
| 946 | end;
|
---|
| 947 | end;
|
---|
| 948 |
|
---|
| 949 | function BaseFont: TFont;
|
---|
| 950 | begin
|
---|
| 951 | result := FBaseFont;
|
---|
| 952 | end;
|
---|
| 953 |
|
---|
| 954 | function MainFont: TFont;
|
---|
| 955 | begin
|
---|
| 956 | if Application.MainForm <> nil
|
---|
| 957 | then Result := Application.MainForm.Font
|
---|
| 958 | else Result := BaseFont;
|
---|
| 959 | end;
|
---|
| 960 |
|
---|
| 961 | function MainFontSize: Integer;
|
---|
| 962 | { return font size of the Main Form in the application }
|
---|
| 963 | begin
|
---|
| 964 | Result := MainFont.Size;
|
---|
| 965 | end;
|
---|
| 966 |
|
---|
| 967 | function FontWidthSubPixel( Font: TFont): real;
|
---|
| 968 | { return in pixels the average character width of the font passed in FontHandle }
|
---|
| 969 | var
|
---|
| 970 | TotalWidth: integer;
|
---|
| 971 | begin
|
---|
| 972 | TotalWidth := TextWidthByFont( Font.Handle,
|
---|
| 973 | 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz');
|
---|
| 974 | result := TotalWidth / 52;
|
---|
| 975 | end;
|
---|
| 976 |
|
---|
| 977 | function FontWidthPixel( Font: TFont): integer;
|
---|
| 978 | begin
|
---|
| 979 | //Round() is too fancy to be correct here
|
---|
| 980 | result := Trunc(FontWidthSubPixel(Font) + 0.5);
|
---|
| 981 | end;
|
---|
| 982 |
|
---|
| 983 | function MainFontWidth: Integer;
|
---|
| 984 | begin
|
---|
| 985 | Result := FontWidthPixel(MainFont);
|
---|
| 986 | end;
|
---|
| 987 |
|
---|
| 988 | function MainFontHeight: Integer;
|
---|
| 989 | { return font size of the Main Form in the application.
|
---|
| 990 | Note that TFont.Height is negative of what we want (see Delphi documentation)}
|
---|
| 991 | begin
|
---|
| 992 | Result := Abs(MainFont.Height);
|
---|
| 993 | end;
|
---|
| 994 |
|
---|
| 995 | procedure RedrawSuspend(AHandle: HWnd);
|
---|
| 996 | begin
|
---|
| 997 | SendMessage(AHandle, WM_SETREDRAW, 0, 0);
|
---|
| 998 | end;
|
---|
| 999 |
|
---|
| 1000 | procedure RedrawActivate(AHandle: HWnd);
|
---|
| 1001 | begin
|
---|
| 1002 | SendMessage(AHandle, WM_SETREDRAW, 1, 0);
|
---|
| 1003 | InvalidateRect(AHandle, nil, True);
|
---|
| 1004 | end;
|
---|
| 1005 |
|
---|
| 1006 | procedure ResetSelectedForList(AListBox: TListBox);
|
---|
| 1007 | var
|
---|
| 1008 | i: Integer;
|
---|
| 1009 | begin
|
---|
| 1010 | with AListBox do for i := 0 to Items.Count - 1 do Selected[i] := False;
|
---|
| 1011 | end;
|
---|
| 1012 |
|
---|
| 1013 | function ResizeWidth( OldFont: TFont; NewFont: TFont; OldWidth: integer): integer;
|
---|
| 1014 | begin
|
---|
| 1015 | result := Trunc( OldWidth *FontWidthSubPixel(NewFont) / FontWidthSubPixel(OldFont)
|
---|
| 1016 | +0.5);
|
---|
| 1017 | end;
|
---|
| 1018 |
|
---|
| 1019 | function ResizeHeight( OldFont: TFont; NewFont: TFont; OldHeight: integer): integer;
|
---|
| 1020 | begin
|
---|
| 1021 | result := Trunc( OldHeight *Abs(NewFont.Height) / Abs(OldFont.Height)
|
---|
| 1022 | +0.5);
|
---|
| 1023 | end;
|
---|
| 1024 |
|
---|
| 1025 | procedure ResizeToFont(FontSize: Integer; var W, H: Integer);
|
---|
| 1026 | { resizes form relative to the font size, assumes form designed with
|
---|
| 1027 | DefaultFont (>MS Sans Serif 8pt<) }
|
---|
| 1028 | var
|
---|
| 1029 | Font: TFont;
|
---|
| 1030 | begin
|
---|
| 1031 | Font := TFont.Create;
|
---|
| 1032 | Font.Name := BaseFontName;
|
---|
| 1033 | Font.Size := FontSize;
|
---|
| 1034 | W := ResizeWidth( BaseFont, Font, W);
|
---|
| 1035 | H := ResizeHeight( BaseFont, Font, H);
|
---|
| 1036 | end;
|
---|
| 1037 |
|
---|
| 1038 | procedure ResizeHeaderControl( OldFont: TFont; NewFont: TFont; Control: THeaderControl);
|
---|
| 1039 | {Tested against fOrders page.}
|
---|
| 1040 | var
|
---|
| 1041 | i: integer;
|
---|
| 1042 | begin
|
---|
| 1043 | for i := 0 to Control.Sections.Count-1 do
|
---|
| 1044 | Control.Sections[i].Width := ResizeWidth( OldFont, NewFont, Control.Sections[i].Width);
|
---|
| 1045 | end;
|
---|
| 1046 |
|
---|
| 1047 | procedure ResizeListView( OldFont: TFont; NewFont: TFont; Control: TListView);
|
---|
| 1048 | var
|
---|
| 1049 | i: integer;
|
---|
| 1050 | begin
|
---|
| 1051 | if not Assigned(Control.OnResize) then
|
---|
| 1052 | for i := 0 to Control.Columns.Count-1 do
|
---|
| 1053 | Control.Columns[i].Width := ResizeWidth( OldFont, NewFont, Control.Columns[i].Width);
|
---|
| 1054 | end;
|
---|
| 1055 |
|
---|
| 1056 | procedure ResizeComboBox( OldFont: TFont; NewFont: TFont; Control: TComboBox);
|
---|
| 1057 | begin
|
---|
| 1058 | Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
|
---|
| 1059 | end;
|
---|
| 1060 |
|
---|
| 1061 | procedure ResizeListBox( OldFont: TFont; NewFont: TFont; Control: TListBox);
|
---|
| 1062 | begin
|
---|
| 1063 | Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
|
---|
| 1064 | end;
|
---|
| 1065 |
|
---|
| 1066 | procedure ResizeCheckListBox( OldFont: TFont; NewFont: TFont; Control: TCheckListBox);
|
---|
| 1067 | begin
|
---|
| 1068 | Control.ItemHeight := ResizeHeight( OldFont, NewFont, Control.ItemHeight);
|
---|
| 1069 | end;
|
---|
| 1070 |
|
---|
| 1071 | procedure ResizeDescendants( OldFont: TFont; NewFont: TFont; AControl: TWinControl);
|
---|
| 1072 | var
|
---|
| 1073 | i: integer;
|
---|
| 1074 | Child: TControl;
|
---|
| 1075 | VisibleWidth, TotalWidth: integer;
|
---|
| 1076 | VisibleHeight, TotalHeight: integer;
|
---|
| 1077 | begin
|
---|
| 1078 | if AControl.Align <> alNone then
|
---|
| 1079 | Application.ProcessMessages;
|
---|
| 1080 | AControl.DisableAlign;
|
---|
| 1081 | try
|
---|
| 1082 | //I think I finally got this next part right, so I will try to explain what
|
---|
| 1083 | //it is doing.
|
---|
| 1084 | //At this stage, the control is resized, but all of the childern are in
|
---|
| 1085 | //original size.
|
---|
| 1086 | //These children are corretly aligned to the visible part of the control,
|
---|
| 1087 | //but may not be correctly aligned in the underlying canvas if there are
|
---|
| 1088 | //scroll bars.
|
---|
| 1089 | //We wish to transform the children to have the correct new size and be
|
---|
| 1090 | //aligned to the new underlying canvas size.
|
---|
| 1091 |
|
---|
| 1092 | //For the widths, I have kept track of what parts of the screen we are
|
---|
| 1093 | //resizing. The height will work the same way.
|
---|
| 1094 | //The notation is A[B]C, where A is the space to the left of the child
|
---|
| 1095 | //control, B is the space containing the child control, and C is the space
|
---|
| 1096 | //to the right.
|
---|
| 1097 | VisibleWidth := AControl.Width;
|
---|
| 1098 | VisibleHeight := AControl.Height;
|
---|
| 1099 | TotalWidth := VisibleWidth;
|
---|
| 1100 | TotalHeight := VisibleHeight;
|
---|
| 1101 | if AControl is TScrollingWinControl then
|
---|
| 1102 | begin
|
---|
| 1103 | TotalWidth := HigherOf(TotalWidth, TScrollingWinControl(AControl).HorzScrollBar.Range);
|
---|
| 1104 | TotalHeight := HigherOf(TotalHeight, TScrollingWinControl(AControl).VertScrollBar.Range);
|
---|
| 1105 | end;
|
---|
| 1106 | for i := 0 to AControl.ControlCount -1 do begin
|
---|
| 1107 | Child := AControl.Controls[i];
|
---|
| 1108 | //Tab sheets auto-size with their parents
|
---|
| 1109 | if not (Child is TTabSheet) then
|
---|
| 1110 | with Child do begin
|
---|
| 1111 | if [akLeft,akRight] <= Anchors then //X[.]X
|
---|
| 1112 | Width := TotalWidth - ResizeWidth( OldFont, NewFont, VisibleWidth - Width)
|
---|
| 1113 | else //.[X].
|
---|
| 1114 | Width := ResizeWidth( OldFont, NewFont, Width);
|
---|
| 1115 | if not(akLeft in Anchors) then //.[X]X
|
---|
| 1116 | Left := TotalWidth - ResizeWidth( OldFont, NewFont, VisibleWidth - Left)
|
---|
| 1117 | else
|
---|
| 1118 | Left := ResizeWidth( OldFont, NewFont, Left); //X[.].
|
---|
| 1119 | if [akTop,akBottom] <= Anchors then
|
---|
| 1120 | Height := TotalHeight - ResizeHeight( OldFont, NewFont, VisibleHeight - Height)
|
---|
| 1121 | else
|
---|
| 1122 | Height := ResizeHeight( OldFont, NewFont, Height);
|
---|
| 1123 | if not(akTop in Anchors) then
|
---|
| 1124 | Top := TotalHeight - ResizeHeight( OldFont, NewFont, VisibleHeight - Top)
|
---|
| 1125 | else
|
---|
| 1126 | Top := ResizeHeight( OldFont, NewFont, Top);
|
---|
| 1127 | end;
|
---|
| 1128 | //Recurse. Let Auto-Size panels take care of themselves
|
---|
| 1129 | if (Child is TWinControl) and not (Child is TORAutoPanel) then
|
---|
| 1130 | ResizeDescendants( OldFont, NewFont, TWinControl(Child));
|
---|
| 1131 | if Child is TComboBox then
|
---|
| 1132 | ResizeComboBox( OldFont, NewFont, TComboBox(Child));
|
---|
| 1133 | if Child is TCheckListBox then
|
---|
| 1134 | ResizeCheckListBox( OldFont, NewFont, TCheckListBox(Child));
|
---|
| 1135 | if Child is THeaderControl then
|
---|
| 1136 | ResizeHeaderControl( OldFont, NewFont, THeaderControl(Child));
|
---|
| 1137 | if Child is TListBox then
|
---|
| 1138 | ResizeListBox( OldFont, NewFont, TListBox(Child));
|
---|
| 1139 | if Child is TListView then
|
---|
| 1140 | ResizeListView( OldFont, NewFont, TListView(Child));
|
---|
| 1141 | if Child is TDrawGrid then with TDrawGrid(Child) do
|
---|
| 1142 | //from Win32 "How to Calculate the Height of Edit Control..."
|
---|
| 1143 | DefaultRowHeight := Abs(NewFont.Height) * 3 div 2;
|
---|
| 1144 | if Child is TTabControl then with TTabControl(Child) do begin
|
---|
| 1145 | if Tabs.Count > 0 then
|
---|
| 1146 | TabWidth := ResizeWidth( OldFont, NewFont, TabWidth);
|
---|
| 1147 | Width := TabWidth * Tabs.Count +3;
|
---|
| 1148 | end;
|
---|
| 1149 | end;
|
---|
| 1150 | finally
|
---|
| 1151 | AControl.EnableAlign;
|
---|
| 1152 | end;
|
---|
| 1153 | end;
|
---|
| 1154 |
|
---|
| 1155 | procedure ResizeChartFonts( OldFont: TFont; NewFont: TFont; Control: TChart);
|
---|
| 1156 | var
|
---|
| 1157 | i: integer;
|
---|
| 1158 | begin
|
---|
| 1159 | with Control do begin
|
---|
| 1160 | if LeftAxis.Title.Font.Size = OldFont.Size then
|
---|
| 1161 | LeftAxis.Title.Font.Size := NewFont.Size;
|
---|
| 1162 | if LeftAxis.LabelsFont.Size = OldFont.Size then
|
---|
| 1163 | LeftAxis.LabelsFont.Size := NewFont.Size;
|
---|
| 1164 | if BottomAxis.Title.Font.Size = OldFont.Size then
|
---|
| 1165 | BottomAxis.Title.Font.Size := NewFont.Size;
|
---|
| 1166 | if BottomAxis.LabelsFont.Size = OldFont.Size then
|
---|
| 1167 | BottomAxis.LabelsFont.Size := NewFont.Size;
|
---|
| 1168 | if Legend.Font.Size = OldFont.Size then
|
---|
| 1169 | Legend.Font.Size := NewFont.Size;
|
---|
| 1170 | if Title.Font.Size = OldFont.Size then
|
---|
| 1171 | Title.Font.Size := NewFont.Size;
|
---|
| 1172 | for i := 0 to SeriesCount - 1 do
|
---|
| 1173 | if Series[i].Marks.Font.Size = OldFont.Size then
|
---|
| 1174 | Series[i].Marks.Font.Size := NewFont.Size;
|
---|
| 1175 | end;
|
---|
| 1176 | end;
|
---|
| 1177 |
|
---|
| 1178 | procedure ResizeFontsInDescendants( OldFont: TFont; NewFont: TFont; AControl: TWinControl);
|
---|
| 1179 | var
|
---|
| 1180 | i: integer;
|
---|
| 1181 | Child: TControl;
|
---|
| 1182 | RESelectionStart: integer;
|
---|
| 1183 | RESelectionLength: integer;
|
---|
| 1184 | begin
|
---|
| 1185 | for i := 0 to AControl.ControlCount -1 do begin
|
---|
| 1186 | Child := AControl.Controls[i];
|
---|
| 1187 | if Child is TRichEdit then begin
|
---|
| 1188 | with TRichEdit(Child) do
|
---|
| 1189 | if Font.Size = OldFont.Size then begin
|
---|
| 1190 | if not ParentFont then
|
---|
| 1191 | Font.Size := NewFont.Size;
|
---|
| 1192 | RESelectionStart := SelStart;
|
---|
| 1193 | RESelectionLength := SelLength;
|
---|
| 1194 | SelectAll;
|
---|
| 1195 | SelAttributes.Size := NewFont.Size;
|
---|
| 1196 | DefAttributes.Size := NewFont.Size;
|
---|
| 1197 | SelStart := RESelectionStart;
|
---|
| 1198 | SelLength := RESelectionLength;
|
---|
| 1199 | end
|
---|
| 1200 | end
|
---|
| 1201 | else
|
---|
| 1202 | if Child is TChart then
|
---|
| 1203 | ResizeChartFonts( OldFont, NewFont, TChart(Child))
|
---|
| 1204 | else
|
---|
| 1205 | with TFontControl(Child) do
|
---|
| 1206 | if (Font.Size = OldFont.Size) and not ParentFont then
|
---|
| 1207 | Font.Size := NewFont.Size;
|
---|
| 1208 |
|
---|
| 1209 | if Child is TWinControl then
|
---|
| 1210 | ResizeFontsInDescendants( OldFont, NewFont, TWinControl(Child));
|
---|
| 1211 | end;
|
---|
| 1212 | end;
|
---|
| 1213 |
|
---|
| 1214 | procedure ForceInsideWorkArea( var Rect: TRect);
|
---|
| 1215 | var
|
---|
| 1216 | Frame: TRect;
|
---|
| 1217 | begin
|
---|
| 1218 | Frame := Screen.WorkAreaRect;
|
---|
| 1219 | {Veritcal version:}
|
---|
| 1220 | {Align bottom (preserving height) if needed}
|
---|
| 1221 | if Rect.Bottom > Frame.Bottom then
|
---|
| 1222 | begin
|
---|
| 1223 | Rect.Top := Rect.Top + Frame.Bottom - Rect.Bottom;
|
---|
| 1224 | Rect.Bottom := Frame.Bottom;
|
---|
| 1225 | end;
|
---|
| 1226 | {Then align top (preserving height) if needed}
|
---|
| 1227 | if Rect.Top < Frame.Top then
|
---|
| 1228 | begin
|
---|
| 1229 | Rect.Bottom := Rect.Bottom + Frame.Top - Rect.Top;
|
---|
| 1230 | Rect.Top := Frame.Top;
|
---|
| 1231 | end;
|
---|
| 1232 | {Now shrink (preserving top) if needed}
|
---|
| 1233 | if Rect.Bottom > Frame.Bottom then
|
---|
| 1234 | Rect.Bottom := Frame.Bottom;
|
---|
| 1235 | {Horizontal version:}
|
---|
| 1236 | if Rect.Right > Frame.Right then
|
---|
| 1237 | begin
|
---|
| 1238 | Rect.Left := Rect.Left + Frame.Right - Rect.Right;
|
---|
| 1239 | Rect.Right := Frame.Right;
|
---|
| 1240 | end;
|
---|
| 1241 | if Rect.Left < Frame.Left then
|
---|
| 1242 | begin
|
---|
| 1243 | Rect.Right := Rect.Right + Frame.Left - Rect.Left;
|
---|
| 1244 | Rect.Left := Frame.Left;
|
---|
| 1245 | end;
|
---|
| 1246 | if Rect.Right > Frame.Right then
|
---|
| 1247 | Rect.Right := Frame.Right;
|
---|
| 1248 | end;
|
---|
| 1249 |
|
---|
| 1250 | procedure ResizeFormToFont(AForm: TForm);
|
---|
| 1251 | var
|
---|
| 1252 | Rect: TRect;
|
---|
| 1253 | begin
|
---|
| 1254 | with AForm do begin
|
---|
| 1255 | ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
|
---|
| 1256 | ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
|
---|
| 1257 | HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
|
---|
| 1258 | VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
|
---|
| 1259 | Rect := BoundsRect;
|
---|
| 1260 | ForceInsideWorkArea(Rect);
|
---|
| 1261 | BoundsRect := Rect;
|
---|
| 1262 | ResizeFontsInDescendants( Font, MainFont, AForm);
|
---|
| 1263 | //Important: We are using the font to calculate everything, so don't
|
---|
| 1264 | //change font until now.
|
---|
| 1265 | Font.Size := MainFont.Size;
|
---|
| 1266 | end;
|
---|
| 1267 | end;
|
---|
| 1268 |
|
---|
| 1269 | procedure ResizeAnchoredFormToFont( AForm: TForm);
|
---|
| 1270 | var
|
---|
| 1271 | Rect: TRect;
|
---|
| 1272 | begin
|
---|
| 1273 | with AForm do begin
|
---|
| 1274 | ClientWidth := ResizeWidth( Font, MainFont, ClientWidth);
|
---|
| 1275 | ClientHeight := ResizeHeight( Font, MainFont, ClientHeight);
|
---|
| 1276 | HorzScrollBar.Range := ResizeWidth( Font, MainFont, HorzScrollBar.Range);
|
---|
| 1277 | VertScrollBar.Range := ResizeHeight( Font, MainFont, VertScrollBar.Range);
|
---|
| 1278 | Rect := BoundsRect;
|
---|
| 1279 | ForceInsideWorkArea(Rect);
|
---|
| 1280 | BoundsRect := Rect;
|
---|
| 1281 | ResizeDescendants( Font, MainFont, AForm);
|
---|
| 1282 | ResizeFontsInDescendants( Font, MainFont, AForm);
|
---|
| 1283 | //Important: We are using the font to calculate everything, so don't
|
---|
| 1284 | //change font until now.
|
---|
| 1285 | Font.Size := MainFont.Size;
|
---|
| 1286 | end;
|
---|
| 1287 | end;
|
---|
| 1288 |
|
---|
| 1289 | procedure SetEqualTabStops(AControl: TControl; TabWidth: Integer = 8);
|
---|
| 1290 | { sets tab stops to match the width when the tab is replaced with TabWidth spaces }
|
---|
| 1291 | const
|
---|
| 1292 | MAX_TABS = 10;
|
---|
| 1293 | POINTS_PER_INCH = 72;
|
---|
| 1294 | var
|
---|
| 1295 | DC: HDC;
|
---|
| 1296 | i, HorzPixelsPerInch, PixelsPerTabWidth, PointsPerTabWidth: Integer;
|
---|
| 1297 | begin
|
---|
| 1298 | if AControl is TRichEdit then with TRichEdit(AControl) do
|
---|
| 1299 | begin
|
---|
| 1300 | DC := GetDC(0);
|
---|
| 1301 | HorzPixelsPerInch := GetDeviceCaps(DC, LOGPIXELSX);
|
---|
| 1302 | ReleaseDC(0, DC);
|
---|
| 1303 | PixelsPerTabWidth := TextWidthByFont(Font.Handle, StringOfChar(' ', TabWidth));
|
---|
| 1304 | PointsPerTabWidth := Round((PixelsPerTabWidth / HorzPixelsPerInch) * POINTS_PER_INCH);
|
---|
| 1305 | for i := 0 to MAX_TABS do Paragraph.Tab[i] := PointsPerTabWidth * Succ(i);
|
---|
| 1306 | end;
|
---|
| 1307 | end;
|
---|
| 1308 |
|
---|
| 1309 | procedure StatusText(const S: string);
|
---|
| 1310 | { sends a user defined message to the main window of an application to display the text
|
---|
| 1311 | found in lParam. Only useful if the main window has message event for this message }
|
---|
| 1312 | begin
|
---|
| 1313 | if (Application.MainForm <> nil) and (Application.MainForm.HandleAllocated)
|
---|
| 1314 | then SendMessage(Application.MainForm.Handle, UM_STATUSTEXT, 0, Integer(PChar(S)));
|
---|
| 1315 | end;
|
---|
| 1316 |
|
---|
| 1317 | function ShowMsgOn(AnExpression: Boolean; const AMsg, ACaption: string): Boolean;
|
---|
| 1318 | begin
|
---|
| 1319 | Result := AnExpression;
|
---|
| 1320 | if Result then InfoBox(AMsg, ACaption, MB_OK);
|
---|
| 1321 | end;
|
---|
| 1322 |
|
---|
| 1323 | function TextWidthByFont(AFontHandle: THandle; const x: string): Integer;
|
---|
| 1324 | { returns the width of a string in pixels, given a FONT handle and string }
|
---|
| 1325 | var
|
---|
| 1326 | DC: HDC;
|
---|
| 1327 | SaveFont: HFont;
|
---|
| 1328 | TextSize: TSize;
|
---|
| 1329 | begin
|
---|
| 1330 | DC := GetDC(0);
|
---|
| 1331 | SaveFont := SelectObject(DC, AFontHandle);
|
---|
| 1332 | GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
|
---|
| 1333 | Result := TextSize.cx;
|
---|
| 1334 | SelectObject(DC, SaveFont);
|
---|
| 1335 | ReleaseDC(0, DC);
|
---|
| 1336 | end;
|
---|
| 1337 |
|
---|
| 1338 | function TextHeightByFont(AFontHandle: THandle; const x: string): Integer;
|
---|
| 1339 | var
|
---|
| 1340 | DC: HDC;
|
---|
| 1341 | SaveFont: HFont;
|
---|
| 1342 | TextSize: TSize;
|
---|
| 1343 |
|
---|
| 1344 | begin
|
---|
| 1345 | DC := GetDC(0);
|
---|
| 1346 | SaveFont := SelectObject(DC, AFontHandle);
|
---|
| 1347 | GetTextExtentPoint32(DC, PChar(x), Length(x), TextSize);
|
---|
| 1348 | Result := TextSize.cy;
|
---|
| 1349 | SelectObject(DC, SaveFont);
|
---|
| 1350 | ReleaseDC(0, DC);
|
---|
| 1351 | end;
|
---|
| 1352 |
|
---|
| 1353 | function WrappedTextHeightByFont(Canvas: TCanvas; NewFont: TFont; ItemText: string; var ARect: TRect): integer;
|
---|
| 1354 | var
|
---|
| 1355 | MyTextMetric: TTextMetric;
|
---|
| 1356 | MyFontName: Array [0..31] of char;
|
---|
| 1357 | MyFontHandle, RealFontHandle: HFONT;
|
---|
| 1358 | begin
|
---|
| 1359 | { The next bit is a bunch of Windows code to accomodate the DrawText calls
|
---|
| 1360 | inside the try..finally block. The issue here comes when resizing the font.
|
---|
| 1361 | The Delphi font property is already set, but the DrawText call uses a
|
---|
| 1362 | Windows handle and the handle's font hasn't been set to the new value.}
|
---|
| 1363 | {This still has a vertical sizing bug when there is text that doesn't wrap but is too
|
---|
| 1364 | wide to display in the window (think long medicine names and 24 pt font on a
|
---|
| 1365 | 640*480 screen)}
|
---|
| 1366 | MyFontHandle := 0;
|
---|
| 1367 | RealFontHandle := 0;
|
---|
| 1368 | if GetTextMetrics(Canvas.Handle, MyTextMetric) then
|
---|
| 1369 | if GetTextFace( Canvas.Handle, 32, @MyFontName) <> 0 then with MyTextMetric do
|
---|
| 1370 | MyFontHandle := CreateFont( NewFont.Height,
|
---|
| 1371 | tmAveCharWidth * Abs(NewFont.Height) div tmHeight,
|
---|
| 1372 | 0,
|
---|
| 1373 | 0,
|
---|
| 1374 | tmWeight,
|
---|
| 1375 | tmItalic,
|
---|
| 1376 | tmUnderlined,
|
---|
| 1377 | tmStruckOut,
|
---|
| 1378 | tmCharSet,
|
---|
| 1379 | OUT_DEFAULT_PRECIS,
|
---|
| 1380 | CLIP_DEFAULT_PRECIS,
|
---|
| 1381 | DEFAULT_QUALITY,
|
---|
| 1382 | FF_DONTCARE or DEFAULT_PITCH,
|
---|
| 1383 | @MyFontName);
|
---|
| 1384 | if MyFontHandle <> 0 then
|
---|
| 1385 | RealFontHandle := SelectObject( Canvas.Handle, MyFontHandle);
|
---|
| 1386 | try
|
---|
| 1387 | result := DrawText(Canvas.Handle, PChar(ItemText), Length(ItemText), ARect,
|
---|
| 1388 | DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK) + 2;
|
---|
| 1389 | finally
|
---|
| 1390 | if MyFontHandle <> 0 then begin
|
---|
| 1391 | SelectObject( Canvas.Handle, RealFontHandle);
|
---|
| 1392 | DeleteObject( MyFontHandle );
|
---|
| 1393 | end;
|
---|
| 1394 | end;
|
---|
| 1395 | end;
|
---|
| 1396 |
|
---|
| 1397 | function NumCharsFitInWidth(AFontHandle: THandle; const x: string; const MaxLen: integer): Integer;
|
---|
| 1398 | var
|
---|
| 1399 | DC: HDC;
|
---|
| 1400 | SaveFont: HFont;
|
---|
| 1401 | TextSize: TSize;
|
---|
| 1402 | TmpX: string;
|
---|
| 1403 | done: boolean;
|
---|
| 1404 | l,h: integer;
|
---|
| 1405 |
|
---|
| 1406 | begin
|
---|
| 1407 | DC := GetDC(0);
|
---|
| 1408 | SaveFont := SelectObject(DC, AFontHandle);
|
---|
| 1409 | try
|
---|
| 1410 | h := length(x);
|
---|
| 1411 | l := 0;
|
---|
| 1412 | Result := h;
|
---|
| 1413 | repeat
|
---|
| 1414 | TmpX := copy(x, 1, Result);
|
---|
| 1415 | GetTextExtentPoint32(DC, PChar(TmpX), Length(TmpX), TextSize);
|
---|
| 1416 | if(TextSize.cx > MaxLen) then
|
---|
| 1417 | begin
|
---|
| 1418 | h := Result;
|
---|
| 1419 | Result := (l+h) div 2;
|
---|
| 1420 | done := (Result <= l);
|
---|
| 1421 | end
|
---|
| 1422 | else
|
---|
| 1423 | begin
|
---|
| 1424 | l := Result;
|
---|
| 1425 | Result := (l+h+1) div 2;
|
---|
| 1426 | done := (Result >= h);
|
---|
| 1427 | end;
|
---|
| 1428 | until(done);
|
---|
| 1429 | finally
|
---|
| 1430 | SelectObject(DC, SaveFont);
|
---|
| 1431 | ReleaseDC(0, DC);
|
---|
| 1432 | end;
|
---|
| 1433 | end;
|
---|
| 1434 |
|
---|
| 1435 | function PopupComponent(Sender: TObject; PopupMenu: TPopupMenu): TComponent;
|
---|
| 1436 | begin
|
---|
| 1437 | if(assigned(PopupMenu) and assigned(Sender) and (Sender is TPopupMenu) and
|
---|
| 1438 | assigned(PopupMenu.PopupComponent)) then
|
---|
| 1439 | Result := PopupMenu.PopupComponent
|
---|
| 1440 | else
|
---|
| 1441 | Result := Screen.ActiveControl;
|
---|
| 1442 | end;
|
---|
| 1443 |
|
---|
| 1444 | procedure ReformatMemoParagraph(AMemo: TCustomMemo);
|
---|
| 1445 | { rewrap lines starting with current line until there is a line that starts with whitespace }
|
---|
| 1446 | var
|
---|
| 1447 | ALine: Integer;
|
---|
| 1448 | x, OldText, NewText: string;
|
---|
| 1449 | begin
|
---|
| 1450 | with AMemo do
|
---|
| 1451 | begin
|
---|
| 1452 | ALine := SendMessage(Handle, EM_LINEFROMCHAR, SelStart, 0);
|
---|
| 1453 | repeat
|
---|
| 1454 | Inc(ALine);
|
---|
| 1455 | until (ALine >= Lines.Count) or (Lines[ALine] = '') or (Ord(Lines[ALine][1]) <= 32);
|
---|
| 1456 | SelLength := SendMessage(Handle, EM_LINEINDEX, ALine, 0) - SelStart - 1;
|
---|
| 1457 | if SelLength < 1 then Exit;
|
---|
| 1458 | OldText := SelText;
|
---|
| 1459 | NewText := '';
|
---|
| 1460 | repeat
|
---|
| 1461 | x := Copy(OldText, 1, Pos(CRLF, OldText) - 1);
|
---|
| 1462 | if Length(x) = 0 then x := OldText;
|
---|
| 1463 | Delete(OldText, 1, Length(x) + 2); {delete text + CRLF}
|
---|
| 1464 | if (NewText <> '') and (Copy(NewText, Length(NewText), 1) <> ' ') and
|
---|
| 1465 | (Copy(x, 1, 1) <> ' ') then NewText := NewText + ' ';
|
---|
| 1466 | NewText := NewText + x;
|
---|
| 1467 | until OldText = '';
|
---|
| 1468 | SelText := NewText;
|
---|
| 1469 | end;
|
---|
| 1470 | end;
|
---|
| 1471 |
|
---|
| 1472 | var
|
---|
| 1473 | uReadOnlyColor: TColor;
|
---|
| 1474 | uHaveReadOnlyColor: boolean = FALSE;
|
---|
| 1475 |
|
---|
| 1476 | function ReadOnlyColor: TColor;
|
---|
| 1477 | begin
|
---|
| 1478 | if not uHaveReadOnlyColor then
|
---|
| 1479 | begin
|
---|
| 1480 | uHaveReadOnlyColor := TRUE;
|
---|
| 1481 | if ColorToRGB(clWindow) = ColorToRGB(clWhite) then
|
---|
| 1482 | uReadOnlyColor := $00F0FBFF
|
---|
| 1483 | else
|
---|
| 1484 | uReadOnlyColor := clWindow;
|
---|
| 1485 | end;
|
---|
| 1486 | Result := uReadOnlyColor;
|
---|
| 1487 | end;
|
---|
| 1488 |
|
---|
| 1489 | { ListBox Grid functions }
|
---|
| 1490 |
|
---|
| 1491 | procedure ListGridDrawCell(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
---|
| 1492 | const x: string; WordWrap: Boolean);
|
---|
| 1493 | var
|
---|
| 1494 | i, Format: Integer;
|
---|
| 1495 | ARect: TRect;
|
---|
| 1496 | begin
|
---|
| 1497 | ARect := AListBox.ItemRect(ARow);
|
---|
| 1498 | ARect.Left := 0;
|
---|
| 1499 | for i := 0 to AColumn - 1 do ARect.Left := ARect.Left + AHeader.Sections[i].Width;
|
---|
| 1500 | Inc(ARect.Left, 2);
|
---|
| 1501 | ARect.Right := ARect.Left + AHeader.Sections[AColumn].Width - 6;
|
---|
| 1502 | if WordWrap
|
---|
| 1503 | then Format := (DT_LEFT or DT_NOPREFIX or DT_WORDBREAK)
|
---|
| 1504 | else Format := (DT_LEFT or DT_NOPREFIX);
|
---|
| 1505 | DrawText(AListBox.Canvas.Handle, PChar(x), Length(x), ARect, Format);
|
---|
| 1506 | end;
|
---|
| 1507 |
|
---|
| 1508 | procedure ListGridDrawLines(AListBox: TListBox; AHeader: THeaderControl; Index: Integer;
|
---|
| 1509 | State: TOwnerDrawState);
|
---|
| 1510 | var
|
---|
| 1511 | i, RightSide: Integer;
|
---|
| 1512 | ARect: TRect;
|
---|
| 1513 | begin
|
---|
| 1514 | with AListBox do
|
---|
| 1515 | begin
|
---|
| 1516 | ARect := ItemRect(Index);
|
---|
| 1517 | if odSelected in State then
|
---|
| 1518 | begin
|
---|
| 1519 | Canvas.Brush.Color := clHighlight;
|
---|
| 1520 | Canvas.Font.Color := clHighlightText
|
---|
| 1521 | end;
|
---|
| 1522 | Canvas.FillRect(ARect);
|
---|
| 1523 | Canvas.Pen.Color := clSilver;
|
---|
| 1524 | Canvas.MoveTo(ARect.Left, ARect.Bottom - 1);
|
---|
| 1525 | Canvas.LineTo(ARect.Right, ARect.Bottom - 1);
|
---|
| 1526 | RightSide := -2;
|
---|
| 1527 | for i := 0 to AHeader.Sections.Count - 1 do
|
---|
| 1528 | begin
|
---|
| 1529 | RightSide := RightSide + AHeader.Sections[i].Width;
|
---|
| 1530 | Canvas.MoveTo(RightSide, ARect.Bottom - 1);
|
---|
| 1531 | Canvas.LineTo(RightSide, ARect.Top);
|
---|
| 1532 | end;
|
---|
| 1533 | end;
|
---|
| 1534 | end;
|
---|
| 1535 |
|
---|
| 1536 | function ListGridRowHeight(AListBox: TListBox; AHeader: THeaderControl; ARow, AColumn: Integer;
|
---|
| 1537 | const x: string): Integer;
|
---|
| 1538 | var
|
---|
| 1539 | ARect: TRect;
|
---|
| 1540 | begin
|
---|
| 1541 | ARect := AListBox.ItemRect(ARow);
|
---|
| 1542 | ARect.Right := AHeader.Sections[AColumn].Width - 6;
|
---|
| 1543 | Result := DrawText(AListBox.Canvas.Handle, PChar(x), Length(x), ARect,
|
---|
| 1544 | DT_CALCRECT or DT_LEFT or DT_NOPREFIX or DT_WORDBREAK) + 2;
|
---|
| 1545 | end;
|
---|
| 1546 |
|
---|
| 1547 | (*
|
---|
| 1548 | procedure SetEditWidth(AMemo: TMemo; AWidth: Integer);
|
---|
| 1549 | begin
|
---|
| 1550 | //SetString(x, nil, AWidth);
|
---|
| 1551 | //for i := 1 to AWidth do x[i] := 'X';
|
---|
| 1552 | end;
|
---|
| 1553 | *)
|
---|
| 1554 |
|
---|
| 1555 | { You MUST pass an address to an object variable to get KillObj to work }
|
---|
| 1556 | procedure KillObj(ptr: Pointer; KillObjects: boolean = FALSE);
|
---|
| 1557 | var
|
---|
| 1558 | Obj: TObject;
|
---|
| 1559 | Lst: TList;
|
---|
| 1560 | SLst: TStringList;
|
---|
| 1561 | i: integer;
|
---|
| 1562 |
|
---|
| 1563 | begin
|
---|
| 1564 | Obj := TObject(ptr^);
|
---|
| 1565 | if(assigned(Obj)) then
|
---|
| 1566 | begin
|
---|
| 1567 | if(KillObjects) then
|
---|
| 1568 | begin
|
---|
| 1569 | if(Obj is TList) then
|
---|
| 1570 | begin
|
---|
| 1571 | Lst := TList(Obj);
|
---|
| 1572 | for i := Lst.count-1 downto 0 do
|
---|
| 1573 | if assigned(Lst[i]) then
|
---|
| 1574 | TObject(Lst[i]).Free;
|
---|
| 1575 | end
|
---|
| 1576 | else
|
---|
| 1577 | if(Obj is TStringList) then
|
---|
| 1578 | begin
|
---|
| 1579 | SLst := TStringList(Obj);
|
---|
| 1580 | for i := SLst.count-1 downto 0 do
|
---|
| 1581 | if assigned(SLst.Objects[i]) then
|
---|
| 1582 | SLst.Objects[i].Free;
|
---|
| 1583 | end;
|
---|
| 1584 | end;
|
---|
| 1585 | Obj.Free;
|
---|
| 1586 | TObject(ptr^) := nil;
|
---|
| 1587 | end;
|
---|
| 1588 | end;
|
---|
| 1589 |
|
---|
| 1590 | { Idle Processing }
|
---|
| 1591 |
|
---|
| 1592 | type
|
---|
| 1593 | TIdleCaller = class(TObject)
|
---|
| 1594 | private
|
---|
| 1595 | FTimerActive: boolean;
|
---|
| 1596 | FCallList: TStringList;
|
---|
| 1597 | FDoneList: TStringList;
|
---|
| 1598 | FOldIdler: TIdleEvent;
|
---|
| 1599 | FTimer: TTimer;
|
---|
| 1600 | protected
|
---|
| 1601 | procedure AppIdle(Sender: TObject; var Done: Boolean);
|
---|
| 1602 | procedure TimerDone(Sender: TObject);
|
---|
| 1603 | public
|
---|
| 1604 | constructor Create;
|
---|
| 1605 | destructor Destroy; override;
|
---|
| 1606 | procedure Add(CallProc, DoneProc: TORIdleCallProc; Msg: string);
|
---|
| 1607 | end;
|
---|
| 1608 |
|
---|
| 1609 | var
|
---|
| 1610 | IdleCaller: TIdleCaller = nil;
|
---|
| 1611 |
|
---|
| 1612 | { TIdleCaller }
|
---|
| 1613 |
|
---|
| 1614 | constructor TIdleCaller.Create;
|
---|
| 1615 | begin
|
---|
| 1616 | inherited;
|
---|
| 1617 | FCallList := TStringList.Create;
|
---|
| 1618 | FDoneList := TStringList.Create;
|
---|
| 1619 | FTimer := TTimer.Create(nil);
|
---|
| 1620 | FTimer.Enabled := FALSE;
|
---|
| 1621 | FTimer.Interval := 2000; // 2 seconds
|
---|
| 1622 | FTimer.OnTimer := TimerDone;
|
---|
| 1623 | FTimerActive := FALSE;
|
---|
| 1624 | FOldIdler := Application.OnIdle;
|
---|
| 1625 | Application.OnIdle := AppIdle;
|
---|
| 1626 | end;
|
---|
| 1627 |
|
---|
| 1628 | destructor TIdleCaller.Destroy;
|
---|
| 1629 | begin
|
---|
| 1630 | Application.OnIdle := FOldIdler;
|
---|
| 1631 | FTimer.Enabled := FALSE;
|
---|
| 1632 | KillObj(@FTimer);
|
---|
| 1633 | KillObj(@FDoneList);
|
---|
| 1634 | KillObj(@FCallList);
|
---|
| 1635 | inherited;
|
---|
| 1636 | end;
|
---|
| 1637 |
|
---|
| 1638 | procedure TIdleCaller.AppIdle(Sender: TObject; var Done: Boolean);
|
---|
| 1639 | begin
|
---|
| 1640 | if(not FTimerActive) and (FCallList.Count > 0) then
|
---|
| 1641 | begin
|
---|
| 1642 | FTimer.Enabled := TRUE;
|
---|
| 1643 | FTimerActive := TRUE;
|
---|
| 1644 | end;
|
---|
| 1645 | if assigned(FOldIdler) then
|
---|
| 1646 | FOldIdler(Sender, Done);
|
---|
| 1647 | end;
|
---|
| 1648 |
|
---|
| 1649 | procedure TIdleCaller.Add(CallProc, DoneProc: TORIdleCallProc; Msg: string);
|
---|
| 1650 | begin
|
---|
| 1651 | FCallList.AddObject(Msg, TObject(@CallProc));
|
---|
| 1652 | FDoneList.AddObject(Msg, TObject(@DoneProc));
|
---|
| 1653 | end;
|
---|
| 1654 |
|
---|
| 1655 | procedure TIdleCaller.TimerDone(Sender: TObject);
|
---|
| 1656 | var
|
---|
| 1657 | CallProc, DoneProc: TORIdleCallProc;
|
---|
| 1658 | CallMsg, DoneMsg: string;
|
---|
| 1659 |
|
---|
| 1660 | begin
|
---|
| 1661 | FTimer.Enabled := FALSE;
|
---|
| 1662 | CallProc := TORIdleCallProc(FCallList.Objects[0]);
|
---|
| 1663 | CallMsg := FCallList[0];
|
---|
| 1664 | DoneProc := TORIdleCallProc(FDoneList.Objects[0]);
|
---|
| 1665 | DoneMsg := FDoneList[0];
|
---|
| 1666 | FCallList.Delete(0);
|
---|
| 1667 | FDoneList.Delete(0);
|
---|
| 1668 |
|
---|
| 1669 | if(assigned(CallProc)) then
|
---|
| 1670 | CallProc(CallMsg);
|
---|
| 1671 | if(assigned(DoneProc)) then
|
---|
| 1672 | DoneProc(DoneMsg);
|
---|
| 1673 |
|
---|
| 1674 | FTimerActive := FALSE;
|
---|
| 1675 | end;
|
---|
| 1676 |
|
---|
| 1677 | { do NOT use CallWhenIdle to call RPCs. Use CallRPCWhenIdle in ORNet. }
|
---|
| 1678 | procedure CallWhenIdle(CallProc: TORIdleCallProc; Msg: String);
|
---|
| 1679 | begin
|
---|
| 1680 | if(not assigned(IdleCaller)) then
|
---|
| 1681 | IdleCaller := TIdleCaller.Create;
|
---|
| 1682 | IdleCaller.Add(CallProc, nil, Msg);
|
---|
| 1683 | end;
|
---|
| 1684 |
|
---|
| 1685 | procedure CallWhenIdleNotifyWhenDone(CallProc, DoneProc: TORIdleCallProc; Msg: String);
|
---|
| 1686 | begin
|
---|
| 1687 | if(not assigned(IdleCaller)) then
|
---|
| 1688 | IdleCaller := TIdleCaller.Create;
|
---|
| 1689 | IdleCaller.Add(CallProc, DoneProc, Msg);
|
---|
| 1690 | end;
|
---|
| 1691 |
|
---|
| 1692 | procedure menuHideAllBut(aMenuItem: tMenuItem; butItems: array of tMenuItem);
|
---|
| 1693 | var
|
---|
| 1694 | aCount, bCount: integer;
|
---|
| 1695 | butFound: boolean;
|
---|
| 1696 | begin
|
---|
| 1697 | for aCount := 0 to (aMenuItem.count - 1) do // Iterate through menu items.
|
---|
| 1698 | begin
|
---|
| 1699 | butFound := false;
|
---|
| 1700 | for bCount := 0 to (length(butItems) - 1) do // Check for match in exceptions array.
|
---|
| 1701 | begin
|
---|
| 1702 | if (aMenuItem.items[aCount] = butItems[bCount]) then
|
---|
| 1703 | begin
|
---|
| 1704 | butFound := true;
|
---|
| 1705 | break;
|
---|
| 1706 | end;
|
---|
| 1707 | end;
|
---|
| 1708 | if (not butFound) then
|
---|
| 1709 | aMenuItem.items[aCount].visible := false; // Hide menu item if not an exception.
|
---|
| 1710 | end;
|
---|
| 1711 | end;
|
---|
| 1712 |
|
---|
| 1713 | function TabIsPressed : Boolean;
|
---|
| 1714 | begin
|
---|
| 1715 | Result := Boolean(Hi(GetKeyState(VK_TAB))) and not Boolean(Hi(GetKeyState(VK_SHIFT)));
|
---|
| 1716 | end;
|
---|
| 1717 |
|
---|
| 1718 | function ShiftTabIsPressed : Boolean;
|
---|
| 1719 | begin
|
---|
| 1720 | Result := Boolean(Hi(GetKeyState(VK_TAB))) and Boolean(Hi(GetKeyState(VK_SHIFT)));
|
---|
| 1721 | end;
|
---|
| 1722 |
|
---|
| 1723 |
|
---|
| 1724 | initialization
|
---|
| 1725 | FBaseFont := TFont.Create;
|
---|
| 1726 | FBaseFont.Name := BaseFontName;
|
---|
| 1727 | FBaseFont.Size := BaseFontSize;
|
---|
| 1728 |
|
---|
| 1729 | finalization
|
---|
| 1730 | FBaseFont.Free;
|
---|
| 1731 | KillObj(@IdleCaller);
|
---|
| 1732 |
|
---|
| 1733 | end.
|
---|