Для того чтобы вывести текст под углом, вытянуть или сжать его нужно воспользоваться структурой LOGFONT. Здесь показаны не все ее возможности, но, на мой взгляд, самые интересные.

procedure TForm1.FormPaint(Sender: TObject);
var
lf: TLogFont;
begin
FillChar(lf, SizeOf(lf), 0);
with lf do
begin
// Высота буквы
lfHeight := 15;

// Ширина буквы
lfWidth := 20;

// Угол наклона в десятых градуса
lfEscapement := 100;

// Жирность 0..1000, 0 - по умолчанию
lfWeight := 1000;

// Курсив
lfItalic := 0;

// Подчеркнут
lfUnderline := 1;

// Зачеркнут
lfStrikeOut := 1;

// CharSet
lfCharSet := RUSSIAN_CharSet;

// Название шрифта
StrCopy(lfFaceName, ‘Arial’);
end;
with Form1.Canvas do
begin
FillRect(ClipRect);
Font.Handle := CreateFontIndirect(lf);
TextOut(0, 100, ‘It is a text string’);
end;
end;

При рисовании линии, особенно под маленьким углом, хорошо различимы отдельные точки. Для устранения этого недостатка я использую уменьшение изображения, как в предыдущем совете.

procedure TForm1.Button1Click(Sender: TObject);
var
x, y: integer;
i, j: integer;
r, g, b: integer;
begin
Form1.Canvas.Pen.Width := 10;
Form1.Canvas.MoveTo(10, 10);
Form1.Canvas.LineTo(90, 20);
for y := 0 to 10 do
begin
for x := 0 to 25 do
begin
r := 0;
for i := 0 to 3 do
for j := 0 to 3 do
r := r + GetRValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
r := round(r / 16);
g := 0;
for i := 0 to 3 do
for j := 0 to 3 do
g := g + GetGValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
g := round(g / 16);
b := 0;
for i := 0 to 3 do
for j := 0 to 3 do
b := b + GetBValue(Form1.Canvas.Pixels[4*x+i, 4*y+j]);
b := round(b / 16);
Form1.Canvas.Pixels[x,y+50] := RGB(r, g, b)
end;
Application.ProcessMessages;
end;
end;

При попытке изобразить некую анимацию использую только средства TCanvas, на экране получается черте-чего. Все мельтешит, дергается, одним словом - не годится.

Для получения ” гладкой” ( не мельтешащей ) анимация в программах не использующих DirectX, я обычно использую следующую технику.

Узким местом в процессе является момент изменения картинки на экране, поэтому рисование нужно проводить на невидимом для пользователя канвасе, и только подготовив там обновляемые участки выводить их на видимый экран.

Для того, чтобы стереть кртинку в том месте где ее уже нет, нужно помнить позицию в которой она была выведена в прошлый раз. Обзовем эту позицию Old: TRect, текущую позицию запомним в New: TRect.

TRect я использую, на сучай если размер отображаемой картинки может изменяться.

Стандартным подходом является написание двух процедур - Hide и Show, одна из которых прячет картинку в старой позиции, выводя участок фона поверх нее, а вторая выводит в новой позиции.
Read more »

{
This code draws an anti-aliased line on a bitmap
This means that the line is not jagged like the
lines drawn using the LineTo() function
}

uses
Graphics, Windows;

type
TRGBTripleArray = array[0..1000] of TRGBTriple;
PRGBTripleArray = ^TRGBTripleArray;

// anti-aliased line
procedure WuLine(ABitmap : TBitmap ; Point1, Point2 : TPoint ; AColor : TColor);
var
deltax, deltay, loop, start, finish : integer;
dx, dy, dydx : single; // fractional parts
LR, LG, LB : byte;
x1, x2, y1, y2 : integer;
begin Read more »

{
The following code allows you to draw a gradient on a canvas with
an arbitrary number of colors (minimum 2).
To draw a gradient on a form’s canvas,
call the DrawGradient() in the OnPaint and OnResize-event handlers.
}

{
Mit dieser Prozedur kann man auf einen Canvas einen Farbverlauf mit
beliebig vielen Farben (min. 2) zeichnen.
Z.B. wenn auf eine Form ein Farbverlauf gezeichnet werden soll,
rufe die DrawGradient() Funktion im OnPaint-Ereignis und
im OnResize-Ereignis der Form auf.
}

procedure DrawGradient(ACanvas: TCanvas; Rect: TRect;
Horicontal: Boolean; Colors: array of TColor);
type
RGBArray = array[0..2] of Byte;
var
x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
Faktor: double;
A: RGBArray;
B: array of RGBArray;
merkw: integer;
merks: TPenStyle;
merkp: TColor;
begin Read more »

Проблема.
Так получилось, что передо мной встала задачи работы с канвой (TCanvas) больших размеров (от 2000 и более точек в одном измерении). Через достаточно короткое время работы я обнаружил, что методы TCanvas иногда ведут себя некорректно. Некорректность поведения заключалась в том, что при определенных условиях графические примитивы, например, прямые линии, либо отображались неправильно, либо просто исчезали. Проверка и перепроверка текста программы ничего не дала. Попытка найти какую-либо информацию о возможных особенностях работы с канвой таких размеров также ни дала положительного результата (может быть, просто плохо искал). Пришлось разбираться самому, а затем и обратиться за советом к некоторым жителям Королевства.
Read more »

unit ship_;

interface

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

type
TForm1 = class(TForm)
Timer1: TTimer;
procedure Timer1Timer(Sender: TObject);
procedure FormActivate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
x, y: integer; // координаты корабля (базовой точки)

implementation

{$R *.DFM}
Read more »

TCanvas автоматически ReleaseDC не вызывает. При создании холста с WindowDC в качестве дескриптора, лучшей идеей будет создание потомка TCanvas (моделированного с TControlCanvas):

type
TWindowCanvas = class(TCanvas)
private
FWinControl: TWinControl;
FDeviceContext: HDC;
procedure SetWinControl(AControl: TWinControl);
protected
procedure CreateHandle; override;
public
destructor Destroy; override;
procedure FreeHandle;
property WinControl: TWinControl read FWinControl write SetWinControl;
end;
Read more »

Пример №1 Проект Lines
“Резиновая” линия.

Этот пример показывает, как можно сделать “резиновую” линию - то есть такую, которая тянется за курсором, пока пользователь удерживает кнопку мыши. Такие линии применяются во всех современных графических редакторах. Второе, что делает этот пример - рисует особые линии, которые невозможно нарисовать с помощью стандартных перьев. В этом примере пять типов линий:

* 1) Линия, состоящая из чередующихся отрезков по пять точек красного, зелёного и синего цветов.
* 2) Каждая точка линии имеет свой случайным образом выбранный цвет.
* 3) Линия, состоящая из отдельных крестиков.
* 4) Линия с переменной толщиной.
* 5) Линия в виде “ёлочки”.

Метод рисования таких линий очень универсален. При этом не надо программировать алгоритмы построения линий (например, алгоритм Брезенхэма), всё делает Win API. Создание новых типов линий очень просто и ограничивается, в основном, только фантазией программиста. Но, к сожалению, описанный метод пригоден только для прямых линий. Эллипс или дугу так не нарисуешь.

Скачать проект: Lines.zip (106 K)

Пример №2 Проект ArcText
Этот пример демонстрирует, как вывести надпись с непрямой базовой линией.

Идея заключается в том, что для каждой буквы рассчитывается свой угол поворота, зависящий от её положения. В данном случае базовая линия представляет собой дугу окружности с заданным радиусом. Начальная точка этой дуги задаётся углом её радиус-вектора с осью Х, конечная определяется длиной надписи. Комментировать в этом примере особенно нечего, достаточно справки по CreateFontIndirect и знания элементарной геометрии.

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Процедура выводит на Canvas семисегментный индикатор,
позволяя управлять включенными сегментами

Процедура выводит на Canvas индикатор семисегментного кода
Вход:
SegStr - Строка содержащая символы горящих сегментов(используемые символы ABCDEFGH)
x,y - координаты верхнего левого угла вывода индикатора
Scale - масштаб индикатора от 1 и выше (множитель)
Hndl - Handle Canvas на который выводится изображение

Зависимости: Стандартные
Автор: Pavel Manzharov, pavel_man@hotmail.com, ICQ:4838921, Москва
Copyright: Pavel Manzharov
Дата: 25 февраля 2003 г.
***************************************************** }
Read more »

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Рисование звёзд и многоугольников

Зависимости: Windows, Graphics
Автор: Fenik, chook_nu@uraltc.ru, Новоуральск
Copyright: Автор Федоровских Николай
Дата: 3 июня 2002 г.
***************************************************** }

procedure DrawStar(Canvas: TCanvas; Center, Pos: TPoint;
R2inPercent, Ends: Byte; DrawCircle: Boolean);
{
Рисование звёзд и многоугольников

Center - центр фигуры;
Pos - точка, лежащая на внешнем радиусе;
R2inPercent - сколько процентов от внешнего радиуса составляет внутренний;
Ends - число концов (внешних углов) фигуры;
DrawCircle - описывать или нет возле фигуры окружность;
Read more »

procedure SetCanvasZoomFactor(Canvas: TCanvas; AZoomFactor: Integer);
var
i: Integer;
begin
if AZoomFactor = 100 then
SetMapMode(Canvas.Handle, MM_TEXT)
else
begin
SetMapMode(Canvas.Handle, MM_ISOTROPIC);
SetWindowExtEx(Canvas.Handle, AZoomFactor, AZoomFactor, nil);
SetViewportExtEx(Canvas.Handle, 100, 100, nil);
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
bitmap: TBitmap;
begin
bitmap := TBitmap.Create;
try
bitmap.Assign(Form1.image1.Picture.Bitmap);
SetCanvasZoomFactor(bitmap.Canvas, 70);
Canvas.Draw(30, 30, bitmap);
finally
bitmap.Free
end;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
OldTextColor: TColorRef;
OldBkColor: TColorRef;
OldBkMode: Integer;
begin
OldTextColor := SetTextColor(Form1.Canvas.Handle, clYellow);
OldBkColor := SetBkColor(Form1.Canvas.Handle, clGreen);
OldBkMode := SetBkMode(Form1.Canvas.Handle, OPAQUE);
TextOut(Form1.Canvas.Handle, 20, 20, ‘Delphi World - лучше всех! ;-)’, 27);
SetBkMode(Form1.Canvas.Handle, OldBkMode);
SetBkColor(Form1.Canvas.Handle, OldBkColor);
SetTextColor(Form1.Canvas.Handle, OldTextColor);
end;

InValidateRect(Canvas.handle,NIL,True);

Если вы используете холст формы, то попробуйте следующее:

InValidateRect(form1.handle,NIL,True);

(или взамен передать дескриптор компонента)

Это очистит хост:

canvas.fillrect(canvas.cliprect);

Canvas.Brush.Color := ClWhite;
Canvas.FillRect(Canvas.ClipRect);

procedure TForm1.Button1Click(Sender: TObject);
begin
PatBlt(Form1.Canvas.Handle, 0, 0,
Form1.ClientWidth, Form1.ClientHeight, WHITENESS);
end;

PatBlt(Form1.Canvas.Handle, 0, 0, Form1.ClientWidth, Form1.ClientHeight, WHITENESS);

unit grid_;

interface

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

type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;

implementation

{$R *.DFM}

procedure TForm1.FormPaint(Sender: TObject);
var
x0, y0: integer; // координаты начала координатных осей
dx, dy: integer; // шаг координатной сетки (в пикселях)
h, w: integer; // высота и ширина области вывода координатной сетки
x, y: integer;
Read more »

unit aplanes_;

interface

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

type
TForm1 = class(TForm)
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;

var
Form1: TForm1;
sky, aplane: TBitMap; // битовые образы: небо и самолет
Read more »

procedure DrawTransparentBmp(Cnv: TCanvas; x,y: Integer; Bmp: TBitmap; clTransparent: TColor);
var
bmpXOR, bmpAND, bmpINVAND, bmpTarget: TBitmap;
oldcol: Longint;
begin
try
bmpAND := TBitmap.Create;
bmpAND.Width := Bmp.Width;
bmpAND.Height := Bmp.Height;
bmpAND.Monochrome := True;
oldcol := SetBkColor(Bmp.Canvas.Handle, ColorToRGB(clTransparent));
BitBlt(bmpAND.Canvas.Handle, 0, 0, Bmp.Width, Bmp.Height, Bmp.Canvas.Handle, 0, 0, SRCCOPY);
SetBkColor(Bmp.Canvas.Handle, oldcol);
Read more »

function MyGetMem(Size: DWORD): Pointer;
begin
Result := Pointer(GlobalAlloc(GPTR, Size));
end;

procedure MyFreeMem(p: Pointer);
begin
if p = nil then Exit;
GlobalFree(THandle(p));
end;

{ This code will fill a bitmap by stretching an image coming from a big bitmap on disk.

FileName.- Name of the uncompressed bitmap to read
DestBitmap.- Target bitmap where the bitmap on disk will be resampled.
BufferSize.- The size of a memory buffer used for reading scanlines from the physical bitmap on disk.
This value will decide how many scanlines can be read from disk at the same time, with always a
minimum value of 2 scanlines.
Read more »

unit Unit1;

interface

uses
Windows, Classes, SysUtils, Graphics, Forms;

type
TRGBArray = array[0..32767] of TRGBTriple;
PRGBArray = ^TRGBArray;

type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
FRegion: THandle;
function CreateRegion(Bmp: TBitmap): THandle;
end;

var
Form1: TForm1;

implementation

{$R *.dfm}
Read more »

Вот кусок одного моего класса, в котором есть две интересные вещицы - проецирование файлов в память и работа с битмэпом в памяти через указатель.

Сразу оговорюсь, что все это работает только под Win95/NT.

type
TarrRGBTriple = array[byte] of TRGBTriple;
ParrRGBTriple = ^TarrRGBTriple;

{организует битмэп размером SX,SY;true_color}

procedure TMBitmap.Allocate(SX, SY: integer);
var
DC: HDC;
begin
if BM <> 0 then
DeleteObject(BM); {удаляем старый битмэп, если был}
BM := 0;
PB := nil;
fillchar(BI, sizeof(BI), 0); Read more »

procedure TForm1.Button1Click(Sender: TObject);
var
TheIcon: TIcon;
TheBitmap: TBitmap;
begin
TheIcon := TIcon.Create;
TheIcon.LoadFromFile(’C:\Program Files\Borland\IcoCur32\EARTH.ICO’);
TheBitmap := TBitmap.Create;
TheBitmap.Height := TheIcon.Height;
TheBitmap.Width := TheIcon.Width;
TheBitmap.Canvas.Draw(0, 0, TheIcon);
Form1.Canvas.Draw(10, 10, TheBitmap);
TheBitmap.Free;
TheIcon.Free;
end;

Способ преобразования изображения размером 32×32 в иконку.

unit main;

interface

uses

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

type

TForm1 = class(TForm)
Button1: TButton;
Image1: TImage;
Image2: TImage;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Read more »

Чтобы преобразовать Icon в Bitmap используйте TImageList. для обратного преобразования замените метод AddIcon на Add, и метод GetBitmap на GetIcon.

function Icon2Bitmap(Icon: TIcon): TBitmap;
begin
with TImageList.Create (nil) do
begin
AddIcon (Icon);
Result := TBitmap.Create;
GetBitmap (0, Result);
Free;
end;
end;

procedure TIconShow.FileListBox1Click(Sender: TObject);
var

MyIcon: TIcon;
MyBitMap: TBitmap;
begin

MyIcon := TIcon.Create;
MyBitMap := TBitmap.Create;

try
{ получаем имя файла и связанную с ним иконку}
strFileName := FileListBox1.Items[FileListBox1.ItemIndex];
StrPCopy(cStrFileName, strFileName);
MyIcon.Handle := ExtractIcon(hInstance, cStrFileName, 0);

{ рисуем иконку на bitmap в speedbutton }
SpeedButton1.Glyph := MyBitMap;
SpeedButton1.Glyph.Width := MyIcon.Width;
SpeedButton1.Glyph.Height := MyIcon.Height;
SpeedButton1.Glyph.Canvas.Draw(0, 0, MyIcon);

SpeedButton1.Hint := strFileName;

finally
MyIcon.Free;
MyBitMap.Free;
end;
end;

function InvertBmp1(SourceBmp: TBitmap): TBitMap;
var
i, j: Longint;
tmp: TBitMap;
red, green, blue: Byte;
PixelColor: Longint;
begin
tmp := TBitmap.Create;
tmp.Width := SourceBmp.Width;
tmp.Height := SourceBmp.Height;
for i := 0 to SourceBmp.Width - 1 do
begin
for j := 0 to SourceBmp.Height - 1 do
begin
PixelColor := ColorToRGB(SourceBmp.Canvas.Pixels[i, j]);
red := PixelColor;
green := PixelColor shr 8;
blue := PixelColor shr 16;
red := 255 - red;
green := 255 - green;
blue := 255 - blue;
tmp.Canvas.pixels[i, j] := (red shl 8 + green) shl 8 + blue;
end;
end;
Result := tmp;
end;

function InvertBmp2(ABitmap : TBitmap) : TBitmap;
var
l_bmp : TBitmap;
begin
l_bmp := TBitmap.Create;
l_bmp.Width := ABitmap.Width;
l_bmp.Height := ABitmap.Height;
l_bmp.PixelFormat := ABitmap.PixelFormat;
BitBlt( l_bmp.Canvas.Handle, 0, 0, l_bmp.Width, l_bmp.Height,
ABitmap.Canvas.Handle, 0, 0, SRCINVERT );
result := l_bmp;
end;

{
Dieses ist eine ziemlich schnelle Methode, eine Farbumkehrung auf einem
Bitmap anzuwenden.
}

{
This is a very fast method to invert the colors of a bitmap.
}

function InvertBitmap(MyBitmap: TBitmap): TBitmap;
var
x, y: Integer;
ByteArray: PByteArray;
begin
MyBitmap.PixelFormat := pf24Bit;
for y := 0 to MyBitmap.Height - 1 do
begin
ByteArray := MyBitmap.ScanLine[y];
for x := 0 to MyBitmap.Width * 3 - 1 do
begin
ByteArray[x] := 255 - ByteArray[x];
end;
end;
Result := MyBitmap;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
Image1.Picture.Bitmap := InvertBitmap(Image1.Picture.Bitmap);
Image1.Refresh;
end;

procedure loadgraphic(naam:string);
var
HResInfo: THandle;
BMF: TBitmapFileHeader;
MemHandle: THandle;
Stream: TMemoryStream;
ResPtr: PByte;
ResSize: Longint;
null:array [0..8] of char;
begin
strpcopy (null, naam);
HResInfo := FindResource(HInstance, null, RT_Bitmap);
ResSize := SizeofResource(HInstance, HResInfo);
MemHandle := LoadResource(HInstance, HResInfo);
ResPtr := LockResource(MemHandle);
Stream := TMemoryStream.Create;
try
Stream.SetSize(ResSize + SizeOf(BMF));
BMF.bfType := $4D42;
Stream.write(BMF, SizeOf(BMF));
Stream.write(ResPtr^, ResSize);
Stream.Seek(0, 0);
Bitmap:=tbitmap.create;
Bitmap.LoadFromStream(Stream);
finally
Stream.Free;
end;
FreeResource(MemHandle);
end;