source: trunk/Packages/Graphics32/GR32_Text_VCL.pas

Last change on this file was 2, checked in by chronos, 5 years ago
File size: 21.5 KB
Line 
1unit GR32_Text_VCL;
2
3(* ***** BEGIN LICENSE BLOCK *****
4 * Version: MPL 1.1 or LGPL 2.1 with linking exception
5 *
6 * The contents of this file are subject to the Mozilla Public License Version
7 * 1.1 (the "License"); you may not use this file except in compliance with
8 * the License. You may obtain a copy of the License at
9 * http://www.mozilla.org/MPL/
10 *
11 * Software distributed under the License is distributed on an "AS IS" basis,
12 * WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License
13 * for the specific language governing rights and limitations under the
14 * License.
15 *
16 * Alternatively, the contents of this file may be used under the terms of the
17 * Free Pascal modified version of the GNU Lesser General Public License
18 * Version 2.1 (the "FPC modified LGPL License"), in which case the provisions
19 * of this license are applicable instead of those above.
20 * Please see the file LICENSE.txt for additional information concerning this
21 * license.
22 *
23 * The Original Code is Vectorial Polygon Rasterizer for Graphics32
24 *
25 * The Initial Developer of the Original Code is
26 * Mattias Andersson <mattias@centaurix.com>
27 *
28 * Portions created by the Initial Developer are Copyright (C) 2012
29 * the Initial Developer. All Rights Reserved.
30 *
31 * Contributor(s):
32 *
33 * ***** END LICENSE BLOCK ***** *)
34
35interface
36
37{$I GR32.inc}
38
39uses
40 Windows, Types, GR32, GR32_Paths, Math;
41
42procedure TextToPath(Font: HFONT; Path: TCustomPath;
43 const ARect: TFloatRect; const Text: WideString; Flags: Cardinal = 0);
44function TextToPolyPolygon(Font: HFONT; const ARect: TFloatRect;
45 const Text: WideString; Flags: Cardinal = 0): TArrayOfArrayOfFloatPoint;
46
47function MeasureTextDC(DC: HDC; const ARect: TFloatRect; const Text: WideString;
48 Flags: Cardinal = 0): TFloatRect; overload;
49function MeasureText(Font: HFONT; const ARect: TFloatRect; const Text: WideString;
50 Flags: Cardinal = 0): TFloatRect;
51
52type
53 TTextHinting = (thNone, thNoHorz, thHinting);
54
55 TKerningPairArray = array [0..0] of TKerningPair;
56 PKerningPairArray = ^TKerningPairArray;
57
58procedure SetHinting(Value: TTextHinting);
59function GetHinting: TTextHinting;
60
61const
62 DT_LEFT = 0; //See also Window's DrawText() flags ...
63 DT_CENTER = 1; //http://msdn.microsoft.com/en-us/library/ms901121.aspx
64 DT_RIGHT = 2;
65 DT_VCENTER = 4;
66 DT_BOTTOM = 8;
67 DT_WORDBREAK = $10;
68 DT_SINGLELINE = $20;
69 DT_NOCLIP = $100;
70 DT_JUSTIFY = 3; //Graphics32 additions ...
71 DT_HORZ_ALIGN_MASK = 3;
72
73implementation
74
75uses
76{$IFDEF USESTACKALLOC}
77 GR32_LowLevel,
78{$ENDIF}
79 SysUtils;
80
81var
82 UseHinting: Boolean;
83 HorzStretch: Integer; // stretching factor when calling GetGlyphOutline()
84 HorzStretch_Inv: Single;
85
86 VertFlip_mat2: TMat2;
87
88const
89 GGO_UNHINTED = $0100;
90 GGODefaultFlags: array [Boolean] of Integer = (GGO_NATIVE or GGO_UNHINTED, GGO_NATIVE);
91
92 TT_PRIM_CSPLINE = 3;
93
94 MaxSingle = 3.4e+38;
95
96// import GetKerningPairs from gdi32 library
97function GetKerningPairs(DC: HDC; Count: DWORD; P: PKerningPair): DWORD;
98 stdcall; external gdi32 name 'GetKerningPairs';
99
100function PointFXtoPointF(const Point: tagPointFX): TFloatPoint; {$IFDEF UseInlining} inline; {$ENDIF}
101begin
102 Result.X := Point.X.Value + Point.X.Fract * FixedToFloat;
103 Result.Y := Point.Y.Value + Point.Y.Fract * FixedToFloat;
104end;
105
106
107{$IFDEF USESTACKALLOC}
108{$W+}
109{$ENDIF}
110function GlyphOutlineToPath(Handle: HDC; Path: TCustomPath;
111 DstX, MaxX, DstY: Single;
112 const Glyph: Integer; out Metrics: TGlyphMetrics): Boolean;
113var
114 I, K, S: Integer;
115 Res: DWORD;
116 GlyphMemPtr, BufferPtr: PTTPolygonHeader;
117 CurvePtr: PTTPolyCurve;
118 P1, P2, P3: TFloatPoint;
119begin
120 Res := GetGlyphOutlineW(Handle, Glyph, GGODefaultFlags[UseHinting], Metrics,
121 0, nil, VertFlip_mat2);
122 if (Res = 0) then Exit;
123
124 Result := DstX + Metrics.gmCellIncX <= MaxX;
125 if not Result or not Assigned(Path) then Exit;
126
127 {$IFDEF USESTACKALLOC}
128 GlyphMemPtr := StackAlloc(Res);
129 {$ELSE}
130 GetMem(GlyphMemPtr, Res);
131 {$ENDIF}
132 BufferPtr := GlyphMemPtr;
133
134 Res := GetGlyphOutlineW(Handle, Glyph, GGODefaultFlags[UseHinting], Metrics,
135 Res, BufferPtr, VertFlip_mat2);
136
137 if (Res = GDI_ERROR) or (BufferPtr^.dwType <> TT_POLYGON_TYPE) then
138 begin
139 {$IFDEF USESTACKALLOC}
140 StackFree(GlyphMemPtr);
141 {$ELSE}
142 FreeMem(GlyphMemPtr);
143 {$ENDIF}
144 Exit;
145 end;
146
147 // Batch each glyph so we're sure that the polygons are rendered as a whole (no pun...)
148 // and not as individual independent polygons.
149 // We're doing this here for completeness but since the path will also be batched at
150 // an outer level it isn't really necessary here.
151 Path.BeginUpdate;
152
153 while Res > 0 do
154 begin
155 S := BufferPtr.cb - SizeOf(TTTPolygonHeader);
156 {$IFDEF HAS_NATIVEINT}
157 NativeInt(CurvePtr) := NativeInt(BufferPtr) + SizeOf(TTTPolygonHeader);
158 {$ELSE}
159 Integer(CurvePtr) := Integer(BufferPtr) + SizeOf(TTTPolygonHeader);
160 {$ENDIF}
161 P1 := PointFXtoPointF(BufferPtr.pfxStart);
162 Path.MoveTo(P1.X + DstX, P1.Y + DstY);
163 while S > 0 do
164 begin
165 case CurvePtr.wType of
166 TT_PRIM_LINE:
167 for I := 0 to CurvePtr.cpfx - 1 do
168 begin
169 P1 := PointFXtoPointF(CurvePtr.apfx[I]);
170 Path.LineTo(P1.X + DstX, P1.Y + DstY);
171 end;
172 TT_PRIM_QSPLINE:
173 begin
174 for I := 0 to CurvePtr.cpfx - 2 do
175 begin
176 P1 := PointFXtoPointF(CurvePtr.apfx[I]);
177 if I < CurvePtr.cpfx - 2 then
178 with PointFXtoPointF(CurvePtr.apfx[I + 1]) do
179 begin
180 P2.x := (P1.x + x) * 0.5;
181 P2.y := (P1.y + y) * 0.5;
182 end
183 else
184 P2 := PointFXtoPointF(CurvePtr.apfx[I + 1]);
185 Path.ConicTo(P1.X + DstX, P1.Y + DstY, P2.X + DstX, P2.Y + DstY);
186 end;
187 end;
188 TT_PRIM_CSPLINE:
189 begin
190 I := 0;
191 while I < CurvePtr.cpfx - 2 do
192 begin
193 P1 := PointFXtoPointF(CurvePtr.apfx[I]);
194 P2 := PointFXtoPointF(CurvePtr.apfx[I + 1]);
195 P3 := PointFXtoPointF(CurvePtr.apfx[I + 2]);
196 Path.CurveTo(P1.X + DstX, P1.Y + DstY, P2.X + DstX, P2.Y + DstY,
197 P3.X + DstX, P3.Y + DstY);
198 Inc(I, 2);
199 end;
200 end;
201 end;
202 K := (CurvePtr.cpfx - 1) * SizeOf(TPointFX) + SizeOf(TTPolyCurve);
203 Dec(S, K);
204
205 {$IFDEF HAS_NATIVEINT}
206 Inc(NativeInt(CurvePtr), K);
207 {$ELSE}
208 Inc(Integer(CurvePtr), K);
209 {$ENDIF}
210 end;
211
212 Path.EndPath(True);
213
214 Dec(Res, BufferPtr.cb);
215 {$IFDEF HAS_NATIVEINT}
216 Inc(NativeInt(BufferPtr), BufferPtr.cb);
217 {$ELSE}
218 Inc(integer(BufferPtr), BufferPtr.cb);
219 {$ENDIF}
220 end;
221
222 {$IFDEF USESTACKALLOC}
223 StackFree(GlyphMemPtr);
224 {$ELSE}
225 FreeMem(GlyphMemPtr);
226 {$ENDIF}
227
228 Path.EndUpdate;
229end;
230{$IFDEF USESTACKALLOC}
231{$W-}
232{$ENDIF}
233
234
235procedure InternalTextToPath(DC: HDC; Path: TCustomPath; const ARect: TFloatRect;
236 const Text: WideString; Flags: Cardinal = 0);
237const
238 CHAR_CR = 10;
239 CHAR_NL = 13;
240 CHAR_SP = 32;
241var
242 GlyphMetrics: TGlyphMetrics;
243 TextMetric: TTextMetric;
244 I, J, TextLen, SpcCount, SpcX, LineStart: Integer;
245 CharValue: Integer;
246 CharOffsets: TArrayOfInteger;
247 CharWidths: TArrayOfInteger;
248 X, Y, XMax, YMax, MaxRight: Single;
249 S: WideString;
250 TextPath: TFlattenedPath;
251 OwnedPath: TFlattenedPath;
252{$IFDEF USEKERNING}
253 NextCharValue: Integer;
254 KerningPairs: PKerningPairArray;
255 KerningPairCount: Integer;
256{$ENDIF}
257
258 procedure AlignTextCenter(CurrentI: Integer);
259 var
260 w, M, N, PathStart, PathEnd, CharStart, CharEnd: Integer;
261 Delta: TFloat;
262 i: Integer;
263 MinX, MaxX: Single;
264 begin
265 Delta := Round(((ARect.Right - ARect.Left) * HorzStretch - X - 1) * 0.5);
266 PathStart := CharOffsets[LineStart];
267 PathEnd := CharOffsets[CurrentI] - 1;
268 if (Flags and DT_SINGLELINE <> 0) and (Flags and DT_NOCLIP <> DT_NOCLIP) then
269 begin
270 MinX := ARect.Left + Delta;
271 MaxX := ARect.Right + Delta;
272 CharStart := LineStart;
273 CharEnd := CurrentI;
274
275 w := Round(Delta);
276 for i := LineStart to CurrentI - 1 do
277 begin
278 if w < Arect.Left then
279 begin
280 CharStart := i + 1;
281 MinX := w + CharWidths[i];
282 end;
283 w := w + CharWidths[i];
284 if w <= ARect.Right then
285 begin
286 CharEnd := i + 1;
287 MaxX := w;
288 end;
289 end;
290
291 if (Flags and DT_WORDBREAK <> 0) then
292 begin
293 if (CharStart > LineStart) and (Text[CharStart] <> ' ') then
294 while (Text[CharStart] <> ' ') and (CharStart < CharEnd) do
295 Inc(CharStart);
296 if (CharEnd < CurrentI) and (Text[CharEnd] <> ' ') then
297 while (Text[CharEnd] <> ' ') and (CharEnd > CharStart) do
298 Dec(CharEnd);
299 MinX := Round(Delta);
300 for i := 0 to CharStart - 1 do
301 MinX := MinX + CharWidths[i];
302 MaxX := Round(Delta);
303 for i := 0 to CharEnd - 1 do
304 MaxX := MaxX + CharWidths[i];
305 end;
306
307 PathStart := CharOffsets[CharStart];
308 PathEnd := CharOffsets[CharEnd] - 1;
309
310 for M := 0 to PathStart - 1 do
311 SetLength(TextPath.Path[M], 0);
312 for M := PathEnd + 1 to CharOffsets[CurrentI] - 1 do
313 SetLength(TextPath.Path[M], 0);
314
315 Delta := Delta + (((MinX - ARect.Left) + (ARect.Right - MaxX)) * 0.5) - MinX;
316 end;
317
318 for M := PathStart to PathEnd do
319 for N := 0 to High(TextPath.Path[M]) do
320 TextPath.Path[M, N].X := TextPath.Path[M, N].X + Delta;
321 end;
322
323 procedure AlignTextRight(CurrentI: Integer);
324 var
325 w, i, M, N, PathStart, PathEnd, CharStart: Integer;
326 Delta: TFloat;
327 begin
328 Delta := Round(ARect.Right * HorzStretch - X - 1);
329 PathStart := CharOffsets[LineStart];
330 PathEnd := CharOffsets[CurrentI] - 1;
331
332 if (Flags and DT_SINGLELINE <> 0) and (Flags and DT_NOCLIP <> DT_NOCLIP) then
333 begin
334 CharStart := LineStart;
335
336 w := 0;
337 for i := LineStart to CurrentI - 1 do
338 begin
339 if w + Delta < Arect.Left then
340 CharStart := i + 1;
341 w := w + CharWidths[i];
342 end;
343
344 if (Flags and DT_WORDBREAK <> 0) then
345 if (CharStart > LineStart) and (Text[CharStart] <> ' ') then
346 while (Text[CharStart] <> ' ') and (CharStart < CurrentI) do
347 Inc(CharStart);
348
349 PathStart := CharOffsets[CharStart];
350
351 for M := 0 to PathStart - 1 do
352 SetLength(TextPath.Path[M], 0);
353 end;
354
355 for M := PathStart to PathEnd do
356 for N := 0 to High(TextPath.Path[M]) do
357 TextPath.Path[M, N].X := TextPath.Path[M, N].X + Delta;
358 end;
359
360 procedure AlignTextLeft(CurrentI: Integer);
361 var
362 w, i, M, PathEnd, CharEnd: Integer;
363 begin
364 if (Flags and DT_SINGLELINE <> 0) and (Flags and DT_NOCLIP <> DT_NOCLIP) then
365 begin
366 CharEnd := LineStart;
367
368 w := 0;
369 for i := LineStart to CurrentI - 1 do
370 begin
371 w := w + CharWidths[i];
372 if w <= (ARect.Right - ARect.Left) then
373 CharEnd := i + 1;
374 end;
375
376 if (Flags and DT_WORDBREAK <> 0) then
377 if (CharEnd < CurrentI) and (Text[CharEnd] <> ' ') then
378 while (Text[CharEnd] <> ' ') and (CharEnd > LineStart) do
379 Dec(CharEnd);
380
381 PathEnd := CharOffsets[CharEnd] - 1;
382
383 for M := PathEnd + 1 to CharOffsets[CurrentI] - 1 do
384 SetLength(TextPath.Path[M], 0);
385 end;
386 end;
387
388 procedure AlignTextJustify(CurrentI: Integer);
389 var
390 L, M, N, PathStart, PathEnd: Integer;
391 SpcDelta, SpcDeltaInc: TFloat;
392 begin
393 if (SpcCount < 1) or (Ord(Text[CurrentI]) = CHAR_CR) then
394 Exit;
395 SpcDelta := (ARect.Right * HorzStretch - X - 1) / SpcCount;
396 SpcDeltaInc := SpcDelta;
397 L := LineStart;
398
399 // Trim leading spaces ...
400 while (L < CurrentI) and (Ord(Text[L]) = CHAR_SP) do Inc(L);
401
402 // Now find first space char in line ...
403 while (L < CurrentI) and (Ord(Text[L]) <> CHAR_SP) do Inc(L);
404
405 PathStart := CharOffsets[L - 1];
406 repeat
407 M := L + 1;
408 while (M < CurrentI) and (Ord(Text[M]) <> CHAR_SP) do Inc(M);
409 PathEnd := CharOffsets[M];
410 L := M;
411 for M := PathStart to PathEnd - 1 do
412 for N := 0 to High(TextPath.Path[M]) do
413 TextPath.Path[M, N].X := TextPath.Path[M, N].X + SpcDeltaInc;
414 SpcDeltaInc := SpcDeltaInc + SpcDelta;
415 PathStart := PathEnd;
416 until L >= CurrentI;
417 end;
418
419 procedure AlignLine(CurrentI: Integer);
420 begin
421 if Assigned(TextPath) and (Length(TextPath.Path) > 0) then
422 case (Flags and DT_HORZ_ALIGN_MASK) of
423 DT_LEFT : AlignTextLeft(CurrentI);
424 DT_CENTER : AlignTextCenter(CurrentI);
425 DT_RIGHT : AlignTextRight(CurrentI);
426 DT_JUSTIFY: AlignTextJustify(CurrentI);
427 end;
428 end;
429
430 procedure AddSpace;
431 begin
432 Inc(SpcCount);
433 X := X + SpcX;
434 end;
435
436 procedure NewLine(CurrentI: Integer);
437 begin
438 if (Flags and DT_SINGLELINE <> 0) then
439 begin
440 AddSpace;
441 Exit;
442 end;
443 AlignLine(CurrentI);
444 X := ARect.Left * HorzStretch;
445 Y := Y + TextMetric.tmHeight;
446 LineStart := CurrentI;
447 SpcCount := 0;
448 end;
449
450 function MeasureTextX(const S: WideString): Integer;
451 var
452 I: Integer;
453 begin
454 Result := 0;
455 for I := 1 to Length(S) do
456 begin
457 CharValue := Ord(S[I]);
458 GetGlyphOutlineW(DC, CharValue,
459 GGODefaultFlags[UseHinting], GlyphMetrics, 0, nil, VertFlip_mat2);
460 Inc(Result, GlyphMetrics.gmCellIncX);
461 end;
462 end;
463
464 function NeedsNewLine(X: Single): Boolean;
465 begin
466 Result := (ARect.Right > ARect.Left) and (X > ARect.Right * HorzStretch);
467 end;
468
469begin
470{$IFDEF USEKERNING}
471 KerningPairs := nil;
472 KerningPairCount := GetKerningPairs(DC, 0, nil);
473 if GetLastError <> 0 then
474 RaiseLastOSError;
475 if KerningPairCount > 0 then
476 begin
477 GetMem(KerningPairs, KerningPairCount * SizeOf(TKerningPair));
478 GetKerningPairs(DC, KerningPairCount, PKerningPair(KerningPairs));
479 end;
480{$ENDIF}
481
482 SpcCount := 0;
483 LineStart := 0;
484 OwnedPath := nil;
485 if (Path <> nil) then
486 begin
487 if (Path is TFlattenedPath) then
488 begin
489 TextPath := TFlattenedPath(Path);
490 TextPath.Clear;
491 end
492 else
493 begin
494 OwnedPath := TFlattenedPath.Create;
495 TextPath := OwnedPath;
496 end
497 end else
498 TextPath := nil;
499
500 GetTextMetrics(DC, TextMetric);
501 TextLen := Length(Text);
502 X := ARect.Left * HorzStretch;
503 Y := ARect.Top + TextMetric.tmAscent;
504 XMax := X;
505
506 if not Assigned(Path) or (ARect.Right = ARect.Left) then
507 MaxRight := MaxSingle //either measuring Text or unbounded Text
508 else
509 MaxRight := ARect.Right * HorzStretch;
510 SetLength(CharOffsets, TextLen + 1);
511 CharOffsets[0] := 0;
512 SetLength(CharWidths, TextLen);
513
514 GetGlyphOutlineW(DC, CHAR_SP, GGODefaultFlags[UseHinting], GlyphMetrics,
515 0, nil, VertFlip_mat2);
516 SpcX := GlyphMetrics.gmCellIncX;
517
518 if (Flags and DT_SINGLELINE <> 0) or (ARect.Left = ARect.Right) then
519 begin
520 // ignore justify when forcing singleline ...
521 if (Flags and DT_JUSTIFY = DT_JUSTIFY) then
522 Flags := Flags and not DT_JUSTIFY;
523
524 // ignore wordbreak when forcing singleline ...
525 //if (Flags and DT_WORDBREAK = DT_WORDBREAK) then
526 // Flags := Flags and not DT_WORDBREAK;
527 MaxRight := MaxSingle;
528 end;
529
530 // Batch whole path construction so we can be sure that the path isn't rendered
531 // while we're still modifying it.
532 if (TextPath <> nil) then
533 TextPath.BeginUpdate;
534
535 for I := 1 to TextLen do
536 begin
537 CharValue := Ord(Text[I]);
538 if CharValue <= 32 then
539 begin
540 if (Flags and DT_SINGLELINE = DT_SINGLELINE) then
541 CharValue := CHAR_SP;
542 if Assigned(TextPath) then
543 // Save path list offset of first path of current glyph
544 CharOffsets[I] := Length(TextPath.Path);
545 CharWidths[i - 1]:= SpcX;
546 case CharValue of
547 CHAR_CR: NewLine(I);
548 CHAR_NL: ;
549 CHAR_SP:
550 begin
551 if Flags and DT_WORDBREAK = DT_WORDBREAK then
552 begin
553 J := I + 1;
554 while (J <= TextLen) and
555 ([Ord(Text[J])] * [CHAR_CR, CHAR_NL, CHAR_SP] = []) do
556 Inc(J);
557 S := Copy(Text, I, J - I);
558 if NeedsNewLine(X + MeasureTextX(S)) then
559 NewLine(I) else
560 AddSpace;
561 end else
562 begin
563 if NeedsNewLine(X + SpcX) then
564 NewLine(I)
565 else
566 AddSpace;
567 end;
568 end;
569 end;
570 end
571 else
572 begin
573 if GlyphOutlineToPath(DC, TextPath, X, MaxRight, Y, CharValue,
574 GlyphMetrics) then
575 begin
576 if Assigned(TextPath) then
577 // Save path list offset of first path of current glyph
578 CharOffsets[I] := Length(TextPath.Path);
579 CharWidths[I - 1]:= GlyphMetrics.gmCellIncX;
580 end else
581 begin
582 if Ord(Text[I - 1]) = CHAR_SP then
583 begin
584 // this only happens without DT_WORDBREAK
585 X := X - SpcX;
586 Dec(SpcCount);
587 end;
588 // the current glyph doesn't fit so a word must be split since
589 // it fills more than a whole line ...
590 NewLine(I - 1);
591 if not GlyphOutlineToPath(DC, TextPath, X, MaxRight, Y, CharValue,
592 GlyphMetrics) then Break;
593 if Assigned(TextPath) then
594 // Save path list offset of first path of current glyph
595 CharOffsets[I] := Length(TextPath.Path);
596 CharWidths[I - 1]:= GlyphMetrics.gmCellIncX;
597 end;
598
599 X := X + GlyphMetrics.gmCellIncX;
600 {$IFDEF USEKERNING}
601 if i < TextLen then NextCharValue := Ord(Text[i + 1]);
602 for J := 0 to KerningPairCount - 1 do
603 begin
604 if (KerningPairs^[J].wFirst = CharValue) and
605 (KerningPairs^[J].wSecond = NextCharValue) then
606 begin
607 X := X + KerningPairs^[J].iKernAmount;
608 break;
609 end;
610 end;
611 {$ENDIF}
612 if X > XMax then XMax := X;
613 end;
614 end;
615 if [(Flags and DT_HORZ_ALIGN_MASK)] * [DT_LEFT, DT_CENTER, DT_RIGHT] <> [] then
616 AlignLine(TextLen);
617
618 YMax := Y + TextMetric.tmHeight - TextMetric.tmAscent;
619 // reverse HorzStretch (if any) ...
620 if (HorzStretch <> 1) and assigned(TextPath) then
621 for I := 0 to High(TextPath.Path) do
622 for J := 0 to High(TextPath.Path[I]) do
623 TextPath.Path[I, J].X := TextPath.Path[I, J].X * HorzStretch_Inv;
624 XMax := XMax * HorzStretch_Inv;
625
626 X := ARect.Right - XMax;
627 Y := ARect.Bottom - YMax;
628 if Flags and (DT_VCENTER or DT_BOTTOM) <> 0 then
629 begin
630 if Flags and DT_VCENTER <> 0 then
631 Y := Y * 0.5;
632 if Assigned(TextPath) then
633 for I := 0 to High(TextPath.Path) do
634 for J := 0 to High(TextPath.Path[I]) do
635 TextPath.Path[I, J].Y := TextPath.Path[I, J].Y + Y;
636 end;
637
638{$IFDEF USEKERNING}
639 if Assigned(KerningPairs) then
640 FreeMem(KerningPairs);
641{$ENDIF}
642
643 if (Path <> nil) then
644 begin
645 TextPath.EndPath; // TODO : Why is this needed?
646
647 if (Path <> TextPath) then
648 Path.Assign(TextPath);
649
650 TextPath.EndUpdate;
651
652 OwnedPath.Free;
653 end;
654end;
655
656procedure TextToPath(Font: HFONT; Path: TCustomPath; const ARect: TFloatRect;
657 const Text: WideString; Flags: Cardinal = 0);
658var
659 DC: HDC;
660 SavedFont: HFONT;
661begin
662 DC := GetDC(0);
663 try
664 SavedFont := SelectObject(DC, Font);
665 InternalTextToPath(DC, Path, ARect, Text, Flags);
666 SelectObject(DC, SavedFont);
667 finally
668 ReleaseDC(0, DC);
669 end;
670end;
671
672function TextToPolyPolygon(Font: HFONT; const ARect: TFloatRect;
673 const Text: WideString; Flags: Cardinal = 0): TArrayOfArrayOfFloatPoint;
674var
675 Path: TFlattenedPath;
676begin
677 Path := TFlattenedPath.Create;
678 try
679 TextToPath(Font, Path, ARect, Text, Flags);
680 Result := Path.Path;
681 finally
682 Path.Free;
683 end;
684end;
685
686function MeasureTextDC(DC: HDC; const ARect: TFloatRect; const Text: WideString;
687 Flags: Cardinal): TFloatRect;
688begin
689 Result := ARect;
690 InternalTextToPath(DC, nil, Result, Text, Flags);
691 Result.Left := Round(Result.Left);
692 Result.Top := Round(Result.Top);
693 Result.Right := Round(Result.Right);
694 Result.Bottom := Round(Result.Bottom);
695end;
696
697function MeasureText(Font: HFONT; const ARect: TFloatRect;
698 const Text: WideString; Flags: Cardinal): TFloatRect;
699var
700 DC: HDC;
701 SavedFont: HFONT;
702begin
703 DC := GetDC(0);
704 try
705 SavedFont := SelectObject(DC, Font);
706 Result := MeasureTextDC(DC, ARect, Text, Flags);
707 SelectObject(DC, SavedFont);
708 finally
709 ReleaseDC(0, DC);
710 end;
711end;
712
713procedure SetHinting(Value: TTextHinting);
714begin
715 UseHinting := Value <> thNone;
716 if (Value = thNoHorz) then
717 HorzStretch := 16 else
718 HorzStretch := 1;
719 HorzStretch_Inv := 1 / HorzStretch;
720 FillChar(VertFlip_mat2, SizeOf(VertFlip_mat2), 0);
721 VertFlip_mat2.eM11.value := HorzStretch;
722 VertFlip_mat2.eM22.value := -1; //reversed Y axis
723end;
724
725function GetHinting: TTextHinting;
726begin
727 if HorzStretch <> 1 then Result := thNoHorz
728 else if UseHinting then Result := thHinting
729 else Result := thNone;
730end;
731
732procedure InitHinting;
733begin
734{$IFDEF NOHORIZONTALHINTING}
735 SetHinting(thNoHorz);
736{$ELSE}
737{$IFDEF NOHINTING}
738 SetHinting(thNone);
739{$ELSE}
740 SetHinting(thHinting);
741{$ENDIF}
742{$ENDIF}
743end;
744
745initialization
746 InitHinting;
747
748end.
Note: See TracBrowser for help on using the repository browser.