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