Вывод текста с обводкой букв.

← →
sergn (2002-12-19 21:12) [0]

Как можно быстро вывести на HDC текст с обводкой букв линией
заданой толщины и цвета.
Есть следующий вариант, но он неприемлимо тормознутый.

Procedure TTextDrawObject.DrawTextOutLine(a_dc: Hdc; a_Pen: hPen; a_x, a_y: integer; a_string:string);
var
oldpen:HPEN;
begin
oldPen := SelectObject(a_dc, a_Pen);
BeginPath(a_dc);
TextOut(a_dc, a_x, a_y, Pchar(a_string), length(a_string));
EndPath(a_dc);
StrokePath(a_dc);
SelectObject(a_dc, oldPen);
end;

← →
Mihey (2002-12-19 23:41) [1]

Самое простое - обвести текст как изображение. У меня есть такой пример. В нём можно нарисовать что-нить, а потом программа делает контур фигуры:

unit main_u;

interface

uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;

type
Tmain = class(TForm)
DrwPanel: TPanel;
ButtonConture: TButton;
ButtonClear: TButton;
DrwBox: TPaintBox;
procedure DrwBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure DrwBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure DrwBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure ButtonClearClick(Sender: TObject);
procedure FormPaint(Sender: TObject);
procedure DrwBoxPaint(Sender: TObject);
procedure ButtonContureClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
main: Tmain;
Pressed: Boolean=False;

implementation

{$R *.DFM}

procedure Tmain.DrwBoxMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Pressed := True;
DrwBox.Canvas.MoveTo(X, Y);
DrwBox.Canvas.LineTo(X, Y);
end;

procedure Tmain.DrwBoxMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
Pressed := False;
end;

procedure Tmain.DrwBoxMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
If Pressed then
DrwBox.Canvas.LineTo(X, Y);
end;

procedure Tmain.ButtonClearClick(Sender: TObject);
var Box: TRect;
begin
With DrwBox do
begin
Box := Rect(0, 0, Width-1, Height-1);
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Box);
end;
end;

procedure Tmain.FormPaint(Sender: TObject);
begin
With DrwBox do
begin
Canvas.Pen.Style := psSolid;
Canvas.Pen.Color := clBlack;
Canvas.Pen.Width := 10;
end;
end;

procedure Tmain.DrwBoxPaint(Sender: TObject);
var Box: TRect;
begin
With DrwBox do
begin
Box := Rect(0, 0, Width-1, Height-1);
Canvas.Brush.Style := bsSolid;
Canvas.Brush.Color := clWhite;
Canvas.FillRect(Box);
end;
end;

procedure Tmain.ButtonContureClick(Sender: TObject);
var x, y: Integer;
begin
With DrwBox do
begin
For y := 0 to Height-1 do
For x := 0 to Width-1 do
begin
If Canvas.Pixels[x, y] = clWhite then
begin
If Canvas.Pixels[x, y+1] = clBlack then
Canvas.Pixels[x, y+1] := clRed;
If Canvas.Pixels[x, y-1] = clBlack then
Canvas.Pixels[x, y-1] := clRed;
If Canvas.Pixels[x, y] = clBlack then
Canvas.Pixels[x, y] := clRed;
If Canvas.Pixels[x+1, y] = clBlack then
Canvas.Pixels[x+1, y] := clRed;
If Canvas.Pixels[x-1, y] = clBlack then
Canvas.Pixels[x-1, y] := clRed;
If Canvas.Pixels[x, y] = clBlack then
Canvas.Pixels[x, y] := clRed;
end;
end;
end;
end;

end.

Программа довольно быстро работает с малыми изображениями. Если заменить Pixels на ScanLine, то получится ещё быстрее.

Вывод текста с обводкой букв. Найти похожие ветки