1 | Unit CustomFontDialog;
|
---|
2 |
|
---|
3 | Interface
|
---|
4 |
|
---|
5 | Uses
|
---|
6 | Classes,
|
---|
7 | Forms,
|
---|
8 | Dialogs,
|
---|
9 | StdCtrls,
|
---|
10 | Buttons,
|
---|
11 | Graphics;
|
---|
12 |
|
---|
13 | Type
|
---|
14 |
|
---|
15 | TCustomFontDialog=Class(TDialog)
|
---|
16 | Private
|
---|
17 | FNameList: TListBox;
|
---|
18 | FNameLabel: TLabel;
|
---|
19 | FSizeCombo: TComboBox;
|
---|
20 | FSizeLabel: TLabel;
|
---|
21 | FStyleLabel: TLabel;
|
---|
22 | FStyleListbox: TListBox;
|
---|
23 | FExampleText: TEdit;
|
---|
24 | FItalicCheck:TCheckBox;
|
---|
25 | FBoldCheck:TCheckBox;
|
---|
26 | FOutlineCheck:TCheckBox;
|
---|
27 | FUnderscoreCheck:TCheckBox;
|
---|
28 | FStrikeOutCheck:TCheckBox;
|
---|
29 | FActualFaceLabel:TLabel;
|
---|
30 | FOKButton:TButton;
|
---|
31 | FCancelButton:TButton;
|
---|
32 | FEditFont: TFont;
|
---|
33 |
|
---|
34 | FAllowSimulations: boolean;
|
---|
35 |
|
---|
36 | FUpdating: boolean;
|
---|
37 | FFontLoadRequired: boolean;
|
---|
38 |
|
---|
39 | Function GetFaceName: String;
|
---|
40 | Procedure SetFaceName( s: String );
|
---|
41 |
|
---|
42 | Function GetStyleName: String;
|
---|
43 | Procedure SetStyleName( s: String );
|
---|
44 |
|
---|
45 | Function GetPointSize: LongInt;
|
---|
46 | Procedure SetPointSize( Value:LongInt );
|
---|
47 |
|
---|
48 | Function GetStyleFont: TFont;
|
---|
49 |
|
---|
50 | Function GetAttributes: TFontAttributes;
|
---|
51 | Procedure SetAttributes( NewValue: TFontAttributes );
|
---|
52 |
|
---|
53 | Procedure InsertSizes;
|
---|
54 | Procedure InsertStyles;
|
---|
55 |
|
---|
56 | Procedure OnSelectFace( Sender: TObject; Index: LongInt );
|
---|
57 | Procedure OnSelectStyle( Sender: TObject; Index: LongInt );
|
---|
58 | Procedure OnSetSize( Sender: TObject );
|
---|
59 | Procedure OnStyleChanged( Sender:TObject );
|
---|
60 |
|
---|
61 | Procedure OnSizeClick( Sender: TObject; Index: longint );
|
---|
62 |
|
---|
63 | Procedure SetEditFont( NewFont:TFont );
|
---|
64 |
|
---|
65 | Function FindFace( FaceName: string ): TFont;
|
---|
66 |
|
---|
67 | Protected
|
---|
68 | Procedure SetupComponent; Override;
|
---|
69 | Procedure SetupShow; Override;
|
---|
70 | Procedure LayoutControls;
|
---|
71 | Procedure Resize; override;
|
---|
72 | Procedure SelectFont;
|
---|
73 | public
|
---|
74 | Property FaceName: String read GetFaceName write SetFaceName;
|
---|
75 | Property StyleName: String read GetStyleName write SetStyleName;
|
---|
76 | Property PointSize: longint read GetPointSize write SetPointSize;
|
---|
77 | Property Attributes: TFontAttributes read GetAttributes write SetAttributes;
|
---|
78 |
|
---|
79 | Property EditFont: TFont Read FEditFont Write SetEditFont;
|
---|
80 | Property AllowSimulations: boolean read FAllowSimulations write FAllowSimulations;
|
---|
81 | End;
|
---|
82 |
|
---|
83 | Exports
|
---|
84 | TCustomFontDialog, 'User', 'CustomFontDialog.bmp';
|
---|
85 |
|
---|
86 | Implementation
|
---|
87 |
|
---|
88 | uses
|
---|
89 | SysUtils,
|
---|
90 | PmWin,
|
---|
91 | StringUtilsUnit;
|
---|
92 |
|
---|
93 | // Returns true if s ends with endstr (case insensitive)
|
---|
94 | Function StringAtEnd( const endStr: string; const s: string ): boolean;
|
---|
95 | Var
|
---|
96 | i, j: integer;
|
---|
97 | Begin
|
---|
98 | Result := false;
|
---|
99 | if Length( s ) < length( endStr ) then
|
---|
100 | exit;
|
---|
101 | j := Length( s );
|
---|
102 | for i := length( endstr ) downto 1 do
|
---|
103 | begin
|
---|
104 | if UpCase( s[ j ] ) <> UpCase( endStr[ i ] ) then
|
---|
105 | exit;
|
---|
106 | dec( j );
|
---|
107 | end;
|
---|
108 | Result := true;
|
---|
109 | End;
|
---|
110 |
|
---|
111 | // Returns S minus count characters from the right
|
---|
112 | Function StringLeftWithout( const S:string; const count:integer ):string;
|
---|
113 | Begin
|
---|
114 | Result := copy( S, 1, length( S )-count );
|
---|
115 | End;
|
---|
116 |
|
---|
117 | Function RemoveIfMatchAtEnd( Var s: string; const SearchString: string ): boolean;
|
---|
118 | begin
|
---|
119 | Result := StringAtEnd( SearchString, s );
|
---|
120 | if Result then
|
---|
121 | s := Trim( StringLeftWithout( s, Length( SearchString ) ) );
|
---|
122 | end;
|
---|
123 |
|
---|
124 | Procedure RemoveStyleNames( Var FaceName: string );
|
---|
125 | Begin
|
---|
126 | FaceName := Trim( FaceName );
|
---|
127 | RemoveIfMatchAtEnd( FaceName, 'Italic' );
|
---|
128 | RemoveIfMatchAtEnd( FaceName, 'Oblique' );
|
---|
129 | RemoveIfMatchAtEnd( FaceName, 'Bold' );
|
---|
130 | RemoveIfMatchAtEnd( FaceName, 'Normal' );
|
---|
131 | end;
|
---|
132 |
|
---|
133 | Function GetFontFamilyName( Font: TFont ): string;
|
---|
134 | begin
|
---|
135 | Result := Font.Family;
|
---|
136 | SubstituteAllOccurencesOfChar( Result, '-', ' ' );
|
---|
137 | SubstituteAllOccurencesOfChar( Result, '_', ' ' );
|
---|
138 |
|
---|
139 | if Result = 'Roman' then
|
---|
140 | if StrStartsWithIgnoringCase(Font.FaceName,'Tms Rmn') then
|
---|
141 | // one particularly stupid example
|
---|
142 | Result := 'Tms Rmn';
|
---|
143 |
|
---|
144 | if Result = 'Swiss' then
|
---|
145 | if StrStartsWithIgnoringCase(Font.FaceName, 'Helv') then
|
---|
146 | // one particularly stupid example
|
---|
147 | Result := 'Helv';
|
---|
148 |
|
---|
149 | // some fonts have family names with styles!
|
---|
150 | RemoveStyleNames( Result );
|
---|
151 |
|
---|
152 | end;
|
---|
153 |
|
---|
154 | Function GetFontStyleName( Font: TFont ): string;
|
---|
155 | var
|
---|
156 | FamilyName: string;
|
---|
157 | begin
|
---|
158 | Result := Font.FaceName;
|
---|
159 | SubstituteAllOccurencesOfChar( Result, '-', ' ' );
|
---|
160 | SubstituteAllOccurencesOfChar( Result, '_', ' ' );
|
---|
161 |
|
---|
162 | FamilyName := GetFontFamilyName( Font );
|
---|
163 | if StrStartsWithIgnoringCase(Result, FamilyName) then
|
---|
164 | begin
|
---|
165 | Result := StrSubstringFrom( Result, length( FamilyName ) + 1 );
|
---|
166 | Result := StrTrimChars( Result, [ ' ', '-', '_' ] );
|
---|
167 |
|
---|
168 | if Result = '' then
|
---|
169 | Result := 'Normal';
|
---|
170 | end;
|
---|
171 | end;
|
---|
172 |
|
---|
173 | Procedure TCustomFontDialog.SetupComponent;
|
---|
174 | Var
|
---|
175 | FontIndex: LongInt;
|
---|
176 | aFont: TFont;
|
---|
177 | FontList: TStringList;
|
---|
178 | FamilyIndex: longint;
|
---|
179 | FontFamilyName: string;
|
---|
180 | FontStyleName: string;
|
---|
181 | Begin
|
---|
182 | Inherited SetupComponent;
|
---|
183 |
|
---|
184 | FAllowSimulations := true;
|
---|
185 |
|
---|
186 | BorderStyle := bsSizeable;
|
---|
187 | BorderIcons := [ biSystemMenu, biMaximize ];
|
---|
188 |
|
---|
189 | Caption := LoadNLSStr( SSelectAFont );
|
---|
190 | Width := 480;
|
---|
191 | Height := 350;
|
---|
192 | MinTrackHeight := 350;
|
---|
193 | MinTrackWidth := 400;
|
---|
194 |
|
---|
195 | // Give controls names for purposes of language support...
|
---|
196 |
|
---|
197 | FNameList := TListBox.Create( self );
|
---|
198 | FNameList.Parent := self;
|
---|
199 | FNameList.Sorted := true;
|
---|
200 | FNameList.Duplicates := false;
|
---|
201 | FNameList.OnItemFocus := OnSelectFace;
|
---|
202 | FNameList.Name := 'NameList';
|
---|
203 |
|
---|
204 | FNameLabel := TLabel.Create( self );
|
---|
205 | FNameLabel.Parent := self;
|
---|
206 | FNameLabel.Caption := '~Name:';
|
---|
207 | FNameLabel.FocusControl := FNameList;
|
---|
208 | FNameLabel.Name := 'NameLabel';
|
---|
209 |
|
---|
210 | FStyleListbox := TListBox.Create( self );
|
---|
211 | FStyleListbox.Parent := self;
|
---|
212 | FStyleListbox.Name := 'StyleListBox';
|
---|
213 | FStyleListBox.Sorted := true;
|
---|
214 | FStyleListBox.OnItemFocus := OnSelectStyle;
|
---|
215 |
|
---|
216 | FStyleLabel := TLabel.Create( self );
|
---|
217 | FStyleLabel.Parent := self;
|
---|
218 | FStyleLabel.Caption := 'S~tyle:';
|
---|
219 | FStyleLabel.FocusControl := FStyleListBox;
|
---|
220 | FStyleLabel.Name := 'StyleLabel';
|
---|
221 |
|
---|
222 | FBoldCheck := TCheckBox.Create( self );
|
---|
223 | FBoldCheck.Parent := self;
|
---|
224 | FBoldCheck.OnClick := OnStyleChanged;
|
---|
225 | FBoldCheck.Caption := '~Bold (Simulated)';
|
---|
226 | FBoldCheck.Name := 'BoldCheck';
|
---|
227 |
|
---|
228 | FItalicCheck := TCheckBox.Create( self );
|
---|
229 | FItalicCheck.Parent := self;
|
---|
230 | FItalicCheck.OnClick := OnStyleChanged;
|
---|
231 | FItalicCheck.Caption := '~Italic (Simulated)';
|
---|
232 | FItalicCheck.Name := 'ItalicCheck';
|
---|
233 |
|
---|
234 | FUnderscoreCheck := TCheckBox.Create( self );
|
---|
235 | FUnderscoreCheck.Parent := self;
|
---|
236 | FUnderscoreCheck.OnClick := OnStyleChanged;
|
---|
237 | FUnderscoreCheck.Caption := LoadNLSStr( SUnderscore );
|
---|
238 | FUnderscoreCheck.Name := 'UnderscoreCheck';
|
---|
239 |
|
---|
240 | FOutlineCheck := TCheckBox.Create( self );
|
---|
241 | FOutlineCheck.Parent := self;
|
---|
242 | FOutlineCheck.OnClick := OnStyleChanged;
|
---|
243 | FOutlineCheck.Caption := LoadNLSStr( SOutline );
|
---|
244 | FOutlineCheck.Name := 'OutlineCheck';
|
---|
245 |
|
---|
246 | FStrikeOutCheck := TCheckBox.Create( self );
|
---|
247 | FStrikeOutCheck.Parent := self;
|
---|
248 | FStrikeOutCheck.OnClick := OnStyleChanged;
|
---|
249 | FStrikeOutCheck.Caption := 'St~rikeout';
|
---|
250 | FStrikeOutCheck.Name := 'StrikeOutCheck';
|
---|
251 |
|
---|
252 | FSizeCombo := TComboBox.Create( self );
|
---|
253 | FSizeCombo.Style := csSimple;
|
---|
254 | FSizeCombo.Parent := self;
|
---|
255 | FSizeCombo.OnChange := OnSetSize;
|
---|
256 | FSizeCombo.OnItemFocus := OnSizeClick;
|
---|
257 | FSizeCombo.Name := 'SizeCombo';
|
---|
258 |
|
---|
259 | FSizeLabel := TLabel.Create( self );
|
---|
260 | FSizeLabel.Parent := self;
|
---|
261 | FSizeLabel.Caption := '~Size:';
|
---|
262 | FSizeLabel.FocusControl := FSizeCombo;
|
---|
263 | FSizeLabel.Name := 'SizeLabel';
|
---|
264 |
|
---|
265 | FExampleText := TEdit.Create( self );
|
---|
266 | FExampleText.Parent := self;
|
---|
267 | FExampleText.Text := 'abc ABC def DEF';
|
---|
268 | FExampleText.Autosize := false;
|
---|
269 | FExampleText.Name := 'ExampleText';
|
---|
270 |
|
---|
271 | FActualFaceLabel := TLabel.Create( self );
|
---|
272 | FActualFaceLabel.Parent := self;
|
---|
273 | FActualFaceLabel.Caption := '';
|
---|
274 | FActualFaceLabel.Name := 'ActualFaceLabel';
|
---|
275 | FActualFaceLabel.Alignment := taRightJustify;
|
---|
276 |
|
---|
277 | For FontIndex := 0 To Screen.FontCount - 1 Do
|
---|
278 | Begin
|
---|
279 | aFont := Screen.Fonts[ FontIndex ];
|
---|
280 |
|
---|
281 | FontStyleName := GetFontStyleName( aFont );
|
---|
282 | FontFamilyName := GetFontFamilyName( aFont );
|
---|
283 |
|
---|
284 | FamilyIndex := FNameList.Items.IndexOf( FontFamilyName );
|
---|
285 | if FamilyIndex = -1 then
|
---|
286 | begin
|
---|
287 | // new family
|
---|
288 | FontList := TStringList.Create;
|
---|
289 | FNameList.Items.AddObject( FontFamilyName, FontList );
|
---|
290 | end
|
---|
291 | else
|
---|
292 | begin
|
---|
293 | FontList := FNameList.Items.Objects[ FamilyIndex ] as TStringList;
|
---|
294 | end;
|
---|
295 | if FontList.IndexOf( FontStyleName ) = -1 then
|
---|
296 | begin
|
---|
297 | // new font for this family
|
---|
298 | FontList.AddObject( FontStyleName, aFont );
|
---|
299 | end;
|
---|
300 | End;
|
---|
301 |
|
---|
302 | FOKButton := InsertButton( Self, 150, 10, 90, 30,
|
---|
303 | LoadNLSStr( SOkButton ),
|
---|
304 | '' );
|
---|
305 | FOKButton.Name := 'OKButton';
|
---|
306 | FOKButton.Default := true;
|
---|
307 | FOKButton.ModalResult := mrOK;
|
---|
308 |
|
---|
309 | FCancelButton := InsertButton( Self, 250, 10, 90, 30,
|
---|
310 | LoadNLSStr( SCancelButton ),
|
---|
311 | '' );
|
---|
312 | FCancelButton.Name := 'CancelButton';
|
---|
313 | FCancelButton.Cancel := true;
|
---|
314 | FCancelButton.ModalResult := mrCancel;
|
---|
315 |
|
---|
316 | LayoutControls;
|
---|
317 |
|
---|
318 | SetEditFont( Screen.DefaultFont );
|
---|
319 | End;
|
---|
320 |
|
---|
321 | Function TCustomFontDialog.FindFace( FaceName: string ): TFont;
|
---|
322 | Var
|
---|
323 | FontIndex: LongInt;
|
---|
324 | aFont: TFont;
|
---|
325 | begin
|
---|
326 | For FontIndex := 0 To Screen.FontCount - 1 Do
|
---|
327 | Begin
|
---|
328 | aFont := Screen.Fonts[ FontIndex ];
|
---|
329 | if AnsiCompareText( aFont.FaceName, FaceName ) = 0 then
|
---|
330 | begin
|
---|
331 | Result := aFont;
|
---|
332 | exit;
|
---|
333 | end;
|
---|
334 | End;
|
---|
335 | Result := nil;
|
---|
336 | end;
|
---|
337 |
|
---|
338 | Procedure TCustomFontDialog.LayoutControls;
|
---|
339 | Var
|
---|
340 | W: longint;
|
---|
341 | H: longint;
|
---|
342 | ExampleH: longint;
|
---|
343 | VSplit: longint;
|
---|
344 | GrpH: longint;
|
---|
345 | TopH: longint;
|
---|
346 | Begin
|
---|
347 | W := ClientWidth;
|
---|
348 | H := ClientHeight;
|
---|
349 |
|
---|
350 | // Example is minimum 40 pixels, or 20% of height
|
---|
351 | ExampleH := 40;
|
---|
352 | if ( H div 5 ) > ExampleH then
|
---|
353 | ExampleH := H div 5;
|
---|
354 |
|
---|
355 | // Base of name/size/style (45 allows for buttons/spacing)
|
---|
356 | VSplit := 45 + ExampleH;
|
---|
357 | TopH := H - VSplit - 25;
|
---|
358 |
|
---|
359 | GrpH := TopH + 20;
|
---|
360 | // Left Bottom Width Height
|
---|
361 | FNameLabel .SetWindowPos( 5, H - 25, W - 210, 20 );
|
---|
362 | FNameList .SetWindowPos( 5, VSplit, W - 210, TopH );
|
---|
363 |
|
---|
364 | FStyleLabel .SetWindowPos( W - 200, H - 25, 120, 20 );
|
---|
365 |
|
---|
366 | FStyleListbox .SetWindowPos( W - 200, H - 100, 145, 75 );
|
---|
367 |
|
---|
368 | FBoldCheck .SetWindowPos( W - 200, H - 125, 145, 20 );
|
---|
369 | FItalicCheck .SetWindowPos( W - 200, H - 145, 145, 20 );
|
---|
370 | FUnderscoreCheck.SetWindowPos( W - 200, H - 165, 145, 20 );
|
---|
371 | FOutlineCheck .SetWindowPos( W - 200, H - 185, 145, 20 );
|
---|
372 | FStrikeOutCheck .SetWindowPos( W - 200, H - 205, 145, 20 );
|
---|
373 |
|
---|
374 | FSizeLabel .SetWindowPos( W - 50, H - 25, 45, 20 );
|
---|
375 | FSizeCombo .SetWindowPos( W - 50, VSplit, 45, TopH );
|
---|
376 |
|
---|
377 | FExampleText .SetWindowPos( 5, 40, W - 10, ExampleH );
|
---|
378 |
|
---|
379 | FActualFaceLabel.SetWindowPos( 180, 10, W - 185, 20 );
|
---|
380 |
|
---|
381 | FOKButton .SetWindowPos( 5, 5, 80, 30 );
|
---|
382 | FCancelButton .SetWindowPos( 90, 5, 80, 30 );
|
---|
383 |
|
---|
384 | End;
|
---|
385 |
|
---|
386 |
|
---|
387 | Procedure TCustomFontDialog.SetupShow;
|
---|
388 | Begin
|
---|
389 | Inherited SetupShow;
|
---|
390 |
|
---|
391 | FNameList.Focus;
|
---|
392 | FOKButton.Default := True;
|
---|
393 |
|
---|
394 | FBoldCheck.Enabled := FAllowSimulations;
|
---|
395 | FItalicCheck.Enabled := FAllowSimulations;
|
---|
396 | if not FAllowSimulations then
|
---|
397 | begin
|
---|
398 | FBoldCheck.Checked := false;
|
---|
399 | FItalicCheck.Checked := false;
|
---|
400 | end;
|
---|
401 |
|
---|
402 | FaceName := GetFontFamilyName( FEditFont );
|
---|
403 | StyleName := GetFontStyleName( FEditFont );
|
---|
404 | PointSize := FEditFont.PointSize;
|
---|
405 | Attributes := FEditFont.Attributes;
|
---|
406 |
|
---|
407 | FFontLoadRequired := false;
|
---|
408 |
|
---|
409 | SelectFont; // display it
|
---|
410 |
|
---|
411 | End;
|
---|
412 |
|
---|
413 | Procedure TCustomFontDialog.Resize;
|
---|
414 | begin
|
---|
415 | inherited Resize;
|
---|
416 | LayoutControls;
|
---|
417 | end;
|
---|
418 |
|
---|
419 | Function TCustomFontDialog.GetFaceName: string;
|
---|
420 | begin
|
---|
421 | if FNameList.ItemIndex = -1 then
|
---|
422 | Result := ''
|
---|
423 | else
|
---|
424 | Result := FNameList.Items[ FNameList.ItemIndex ];
|
---|
425 | end;
|
---|
426 |
|
---|
427 | Procedure TCustomFontDialog.SetFaceName( s: string );
|
---|
428 | begin
|
---|
429 | FNameList.ItemIndex := FNameList.Items.IndexOf( s );
|
---|
430 |
|
---|
431 | if FNameList.ItemIndex > 4 then
|
---|
432 | FNameList.TopIndex := FNameList.ItemIndex - 4
|
---|
433 | else
|
---|
434 | FNameList.TopIndex := 0;
|
---|
435 | end;
|
---|
436 |
|
---|
437 | Function TCustomFontDialog.GetStyleName: String;
|
---|
438 | begin
|
---|
439 | if FStyleListBox.ItemIndex = -1 then
|
---|
440 | Result := ''
|
---|
441 | else
|
---|
442 | Result := FStyleListBox.Items[ FStyleListBox.ItemIndex ];
|
---|
443 | end;
|
---|
444 |
|
---|
445 | Procedure TCustomFontDialog.SetStyleName( s: String );
|
---|
446 | begin
|
---|
447 | FStyleListBox.ItemIndex := FStyleListBox.Items.IndexOf( s );
|
---|
448 |
|
---|
449 | if FNameList.ItemIndex = -1 then
|
---|
450 | FNameList.ItemIndex := 0;
|
---|
451 | end;
|
---|
452 |
|
---|
453 | Function TCustomFontDialog.GetAttributes: TFontAttributes;
|
---|
454 | Begin
|
---|
455 | Result :=[];
|
---|
456 | If FItalicCheck.Checked Then
|
---|
457 | Include( Result, faItalic );
|
---|
458 | If FBoldCheck.Checked Then
|
---|
459 | Include( Result, faBold );
|
---|
460 | If FOutlineCheck.Checked Then
|
---|
461 | Include( Result, faOutline );
|
---|
462 | If FStrikeOutCheck.Checked Then
|
---|
463 | Include( Result, faStrikeOut );
|
---|
464 | If FUnderscoreCheck.Checked Then
|
---|
465 | Include( Result, faUnderScore );
|
---|
466 | End;
|
---|
467 |
|
---|
468 | Procedure TCustomFontDialog.SetAttributes( NewValue: TFontAttributes );
|
---|
469 | Begin
|
---|
470 | if FAllowSimulations then
|
---|
471 | begin
|
---|
472 | FBoldCheck.Checked := faBold in NewValue;
|
---|
473 | FItalicCheck.Checked := faItalic in NewValue;
|
---|
474 | end;
|
---|
475 | FOutlineCheck.Checked := faOutline in NewValue;
|
---|
476 | FStrikeoutCheck.Checked := faStrikeout in NewValue;
|
---|
477 | FUnderscoreCheck.Checked := faUnderscore in NewValue;
|
---|
478 | End;
|
---|
479 |
|
---|
480 | Function TCustomFontDialog.GetPointSize: LongInt;
|
---|
481 | Var
|
---|
482 | S: String;
|
---|
483 | C: Integer;
|
---|
484 | Begin
|
---|
485 | S := FSizeCombo.Text;
|
---|
486 | Val( S, Result, C );
|
---|
487 | If C <> 0 Then
|
---|
488 | // invalid conversion
|
---|
489 | Result := 0;
|
---|
490 | End;
|
---|
491 |
|
---|
492 | Procedure TCustomFontDialog.SetPointSize( Value:LongInt );
|
---|
493 | Begin
|
---|
494 | If Value = 0 Then
|
---|
495 | Value := 8;
|
---|
496 | FSizeCombo.Text := IntToStr( Value );
|
---|
497 |
|
---|
498 | // if there's an exact match, select it, if not select nothing
|
---|
499 | FSizeCombo.ItemIndex := FSizeCombo.Items.IndexOf( IntToStr( Value ) );
|
---|
500 | End;
|
---|
501 |
|
---|
502 | Function TCustomFontDialog.GetStyleFont: TFont;
|
---|
503 | begin
|
---|
504 | if FStyleListBox.ItemIndex = -1 then
|
---|
505 | begin
|
---|
506 | // during startup
|
---|
507 | Result := Screen.DefaultFont;
|
---|
508 | exit;
|
---|
509 | end;
|
---|
510 | Result := FStyleListBox.Items.Objects[ FStyleListBox.ItemIndex ] as TFont;
|
---|
511 |
|
---|
512 | end;
|
---|
513 |
|
---|
514 | Procedure TCustomFontDialog.SelectFont;
|
---|
515 | var
|
---|
516 | Attrs: TFontAttributes;
|
---|
517 | StyleFont: TFont;
|
---|
518 | begin
|
---|
519 | if FFontLoadRequired then
|
---|
520 | // we are starting up and don't want to set edit font yet!
|
---|
521 | exit;
|
---|
522 |
|
---|
523 | Screen.Cursor := crHourGlass; // in case it takes a while to load up the font
|
---|
524 |
|
---|
525 | Attrs := GetAttributes;
|
---|
526 |
|
---|
527 | StyleFont := GetStyleFont;
|
---|
528 |
|
---|
529 | DereferenceFont( FEditFont );
|
---|
530 | FEditFont :=
|
---|
531 | Screen.CreateCompatibleFont(
|
---|
532 | Screen.GetFontFromPointSize( StyleFont.FaceName,
|
---|
533 | GetPointSize ) );
|
---|
534 | FEditFont.Attributes := GetAttributes;
|
---|
535 |
|
---|
536 | FActualFaceLabel.Caption := StyleFont.FaceName;
|
---|
537 |
|
---|
538 | FExampleText.Font := FEditFont;
|
---|
539 |
|
---|
540 | Screen.Cursor := crDefault;
|
---|
541 | end;
|
---|
542 |
|
---|
543 | Procedure TCustomFontDialog.SetEditFont( NewFont:TFont );
|
---|
544 | Begin
|
---|
545 | If NewFont = Nil Then
|
---|
546 | NewFont := Screen.DefaultFont;
|
---|
547 |
|
---|
548 | DereferenceFont( FEditFont );
|
---|
549 | FEditFont := NewFont;
|
---|
550 | ReferenceFont( FEditFont );
|
---|
551 |
|
---|
552 | if Handle <> 0 then
|
---|
553 | begin
|
---|
554 | FaceName := GetFontFamilyName( NewFont );
|
---|
555 | StyleName := GetFontStyleName( NewFont );
|
---|
556 | PointSize := NewFont.PointSize;
|
---|
557 | Attributes := NewFont.Attributes;
|
---|
558 | end
|
---|
559 | else
|
---|
560 | begin
|
---|
561 | FFontLoadRequired := true;
|
---|
562 | end;
|
---|
563 | End;
|
---|
564 |
|
---|
565 | const
|
---|
566 | StandardOutlineSizes: array[ 0 .. 11 ] of longint =
|
---|
567 | (
|
---|
568 | 4, 5, 6, 8, 10, 12,
|
---|
569 | 15, 18, 24, 36, 48, 72
|
---|
570 | );
|
---|
571 |
|
---|
572 | function LongintListCompare( Item1: pointer;
|
---|
573 | Item2: pointer ): longint;
|
---|
574 | begin
|
---|
575 | if item1 < item2 then
|
---|
576 | result := -1
|
---|
577 | else if item1 > item2 then
|
---|
578 | result := 1
|
---|
579 | else
|
---|
580 | result := 0;
|
---|
581 | end;
|
---|
582 |
|
---|
583 | Procedure TCustomFontDialog.InsertStyles;
|
---|
584 | var
|
---|
585 | FontList: TStringList;
|
---|
586 | OldStyleName: string;
|
---|
587 | NewIndex: longint;
|
---|
588 | begin
|
---|
589 | FontList := FNameList.Items.Objects[ FNameList.ItemIndex ] as TStringList;
|
---|
590 | if FStyleListbox.ItemIndex <> -1 then
|
---|
591 | OldStyleName := FStyleListbox.Items[ FStyleListbox.ItemIndex ]
|
---|
592 | else
|
---|
593 | OldStyleName := 'Normal';
|
---|
594 | FStyleListbox.Items.Assign( FontList );
|
---|
595 |
|
---|
596 | NewIndex := FStyleListbox.Items.IndexOf( OldStyleName );
|
---|
597 | if NewIndex = -1 then
|
---|
598 | NewIndex := FStyleListbox.Items.IndexOf( 'Normal' );
|
---|
599 | if NewIndex = -1 then
|
---|
600 | NewIndex := 0;
|
---|
601 | FStyleListbox.ItemIndex := NewIndex;
|
---|
602 | end;
|
---|
603 |
|
---|
604 | Procedure TCustomFontDialog.InsertSizes;
|
---|
605 | var
|
---|
606 | Face: string;
|
---|
607 | TheFont: TFont;
|
---|
608 | FontIndex: longint;
|
---|
609 | SizeIndex: longint;
|
---|
610 | OldSize: longint;
|
---|
611 | SizeString: string;
|
---|
612 |
|
---|
613 | LimitedSizes: boolean;
|
---|
614 | Size: longint;
|
---|
615 | NearestSize: longint;
|
---|
616 | NearestSizeIndex: longint;
|
---|
617 |
|
---|
618 | Sizes: TList;
|
---|
619 |
|
---|
620 | procedure AddSize( const size: longint );
|
---|
621 | begin
|
---|
622 | if Sizes.IndexOf( pointer( size ) ) = -1 then
|
---|
623 | Sizes.Add( pointer( size ) );
|
---|
624 | end;
|
---|
625 | Begin
|
---|
626 | Sizes := TList.Create;
|
---|
627 |
|
---|
628 | Face := GetStyleFont.FaceName;
|
---|
629 | try
|
---|
630 | OldSize := StrToInt( FSizeCombo.Caption );
|
---|
631 | except
|
---|
632 | OldSize := 8;
|
---|
633 | end;
|
---|
634 |
|
---|
635 | FSizeCombo.BeginUpdate;
|
---|
636 | FSizeCombo.Clear;
|
---|
637 |
|
---|
638 | LimitedSizes := true;
|
---|
639 |
|
---|
640 | For FontIndex := 0 To Screen.FontCount - 1 Do
|
---|
641 | Begin
|
---|
642 | TheFont := Screen.Fonts[ FontIndex ];
|
---|
643 | If TheFont.FaceName = Face Then
|
---|
644 | Begin
|
---|
645 | // this is a font for the current face.
|
---|
646 | if TheFont.FontType = ftBitmap then
|
---|
647 | begin
|
---|
648 | // just insert the specified point size
|
---|
649 | AddSize( TheFont.NominalPointSize );
|
---|
650 | end
|
---|
651 | else
|
---|
652 | begin
|
---|
653 | // an outline font...
|
---|
654 | LimitedSizes := false;
|
---|
655 | for SizeIndex := Low( StandardOutlineSizes ) to High( StandardOutlineSizes ) do
|
---|
656 | begin
|
---|
657 | AddSize( StandardOutlineSizes[ SizeIndex ] );
|
---|
658 | end;
|
---|
659 | end;
|
---|
660 | end;
|
---|
661 | End;
|
---|
662 |
|
---|
663 | // sort from small to large
|
---|
664 | Sizes.Sort( LongintListCompare );
|
---|
665 |
|
---|
666 | // add to combobox
|
---|
667 | For SizeIndex := 0 to Sizes.Count - 1 do
|
---|
668 | begin
|
---|
669 | SizeString := IntToStr( longint( Sizes[ SizeIndex ] ) );
|
---|
670 | FSizeCombo.Items.Add( SizeString );
|
---|
671 | end;
|
---|
672 |
|
---|
673 | if LimitedSizes then
|
---|
674 | begin
|
---|
675 | // Find nearest match for old size
|
---|
676 | if Sizes.Count > 0 then
|
---|
677 | begin
|
---|
678 | NearestSizeIndex := 0;
|
---|
679 | NearestSize := longint( Sizes[ 0 ] );
|
---|
680 | for SizeIndex := 1 to Sizes.Count - 1 do
|
---|
681 | begin
|
---|
682 | Size := longint( Sizes[ SizeIndex ] );
|
---|
683 | if Abs( Size - OldSize ) < Abs( NearestSize - OldSize ) then
|
---|
684 | begin
|
---|
685 | // closer,
|
---|
686 | NearestSizeIndex := SizeIndex;
|
---|
687 | NearestSize := Size;
|
---|
688 | end;
|
---|
689 | end;
|
---|
690 | end
|
---|
691 | else
|
---|
692 | begin
|
---|
693 | NearestSizeIndex := -1;
|
---|
694 | end;
|
---|
695 |
|
---|
696 | FSizeCombo.ItemIndex := NearestSizeIndex;
|
---|
697 | end
|
---|
698 | else
|
---|
699 | begin
|
---|
700 | FSizeCombo.Text := IntToStr( OldSize );
|
---|
701 |
|
---|
702 | // if there's an exact match, select it, if not select nothing
|
---|
703 | NearestSizeIndex := FSizeCombo.Items.IndexOf( IntToStr( OldSize ) );
|
---|
704 |
|
---|
705 | FSizeCombo.ItemIndex := NearestSizeIndex
|
---|
706 |
|
---|
707 | end;
|
---|
708 |
|
---|
709 | FSizeCombo.EndUpdate;
|
---|
710 |
|
---|
711 | Sizes.Destroy;
|
---|
712 | End;
|
---|
713 |
|
---|
714 |
|
---|
715 | {$HINTS OFF}
|
---|
716 | Procedure TCustomFontDialog.OnSelectFace( Sender: TObject; Index: LongInt );
|
---|
717 | Begin
|
---|
718 | FUpdating := true;
|
---|
719 | InsertStyles;
|
---|
720 | InsertSizes;
|
---|
721 | FUpdating := false;
|
---|
722 | SelectFont;
|
---|
723 | End;
|
---|
724 |
|
---|
725 | Procedure TCustomFontDialog.OnSelectStyle( Sender: TObject; Index: LongInt );
|
---|
726 | Begin
|
---|
727 | if FUpdating then
|
---|
728 | exit;
|
---|
729 | FUpdating := true;
|
---|
730 | InsertSizes;
|
---|
731 | FUpdating := false;
|
---|
732 | SelectFont;
|
---|
733 | End;
|
---|
734 |
|
---|
735 | Procedure TCustomFontDialog.OnSetSize( Sender: TObject );
|
---|
736 | Begin
|
---|
737 | if FUpdating then
|
---|
738 | exit;
|
---|
739 | SelectFont;
|
---|
740 | End;
|
---|
741 |
|
---|
742 | Procedure TCustomFontDialog.OnSizeClick( Sender: TObject; Index: longint );
|
---|
743 | Begin
|
---|
744 | // make a single click select
|
---|
745 | FSizeCombo.Text := FSizeCombo.Items[ Index ];
|
---|
746 | End;
|
---|
747 |
|
---|
748 | Procedure TCustomFontDialog.OnStyleChanged( Sender:TObject );
|
---|
749 | Begin
|
---|
750 | SelectFont;
|
---|
751 | End;
|
---|
752 |
|
---|
753 | Initialization
|
---|
754 | {Register classes}
|
---|
755 | RegisterClasses([TCustomFontDialog]);
|
---|
756 | End.
|
---|
757 |
|
---|