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