unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, XPMan, ExtCtrls, StdCtrls, ComCtrls;
type
TForm1 = class(TForm)
XPManifest1: TXPManifest;
Image1: TImage;
Image2: TImage;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Label4: TLabel;
TrackBar1: TTrackBar;
TrackBar2: TTrackBar;
TrackBar3: TTrackBar;
TrackBar4: TTrackBar;
Edit1: TEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
procedure Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
procedure TrackBar1Change(Sender: TObject);
procedure TrackBar2Change(Sender: TObject);
procedure TrackBar3Change(Sender: TObject);
procedure TrackBar4Change(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
Clicked: Boolean;
implementation
{$R *.dfm}
function ToHex(x: Integer): AnsiString;
var
i: Integer;
begin
result := '';
for i := 1 to 2 do
begin
case x mod 16 of
0: result := '0' + result;
1: result := '1' + result;
2: result := '2' + result;
3: result := '3' + result;
4: result := '4' + result;
5: result := '5' + result;
6: result := '6' + result;
7: result := '7' + result;
8: result := '8' + result;
9: result := '9' + result;
10: result := 'a' + result;
11: result := 'b' + result;
12: result := 'c' + result;
13: result := 'd' + result;
14: result := 'e' + result;
15: result := 'f' + result;
end;
x := x shr 4;
end;
end;
procedure Paint1;
begin
Form1.Image2.Canvas.Brush.Color := Form1.TrackBar1.Position + Form1.TrackBar2.Position shl 8 + Form1.TrackBar3.Position shl 16;
Form1.Image2.Canvas.FillRect(Form1.Image2.ClientRect);
end;
procedure TForm1.FormCreate(Sender: TObject);
var
i: Integer;
Path: AnsiString;
begin
Image1.Canvas.Brush.Color := $ffffff;
Image1.Canvas.FillRect(Form1.Image1.ClientRect);
Image2.Canvas.Brush.Color := $000000;
Image2.Canvas.FillRect(Form1.Image2.ClientRect);
Path := Application.ExeName;
i := Length(Path);
while Path[i] <> '\' do
begin
i := i - 1;
end;
Delete(Path, i + 1, Length(Path) - i);
Edit1.Text := Path + 'tiz.gif';
end;
procedure TForm1.Image1MouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Clicked := True;
end;
procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X, Y: Integer);
var
i, j: Integer;
begin
if Clicked then
begin
for i := -TrackBar4.Position to TrackBar4.Position do
begin
for j := -TrackBar4.Position to TrackBar4.Position do
begin
Image1.Canvas.Pixels[X + i, Y + j] := TrackBar1.Position + TrackBar2.Position shl 8 + TrackBar3.Position shl 16;
end;
end;
end;
end;
procedure TForm1.Image1MouseUp(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
Clicked := False;
end;
procedure TForm1.TrackBar1Change(Sender: TObject);
begin
Label1.Caption := 'Red: ' + IntToStr(TrackBar1.Position) + ' (' + ToHex(TrackBar1.Position) + ')';
Paint1;
end;
procedure TForm1.TrackBar2Change(Sender: TObject);
begin
Label2.Caption := 'Green: ' + IntToStr(TrackBar2.Position) + ' (' + ToHex(TrackBar2.Position) + ')';
Paint1;
end;
procedure TForm1.TrackBar3Change(Sender: TObject);
begin
Label3.Caption := 'Blue: ' + IntToStr(TrackBar3.Position) + ' (' + ToHex(TrackBar3.Position) + ')';
Paint1;
end;
procedure TForm1.TrackBar4Change(Sender: TObject);
begin
Label4.Caption := 'Толщина: ' + IntToStr(TrackBar4.Position);
end;
procedure TForm1.Button1Click(Sender: TObject);
const
Block = 4 * 1024;
var
Buffer: Integer;
Bytes: DWORD;
Colors: array [1..256, (red, green, blue)] of Byte;
Content: array [1..Block] of Byte;
F: THandle;
Flags: Byte;
i, j, k, n: Integer;
w: Word;
begin
F := CreateFile(PChar(Edit1.Text), GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0);
//Пишем заголовок, 6 байт
Buffer := Length('GIF89a');
for i := 1 to Buffer do
begin
Content[i] := Ord('GIF89a'[i]);
end;
WriteFile(F, Content, Buffer, Bytes, nil);
//Пишем длину изображения, 2 байта
WriteFile(F, Image1.Width, SizeOf(Word), Bytes, nil);
//Пишем высоту изображения, 2 байта
WriteFile(F, Image1.Height, SizeOf(Word), Bytes, nil);
//Пишем флаги
//Бит 7 - наличие глобальной палитры
//Биты 4-6 - количество битов на цвет
//По сути качество картинки, нам нужно всегда максимальное
//Бит 3 - флаг сортировки палитры, обычно стоит ноль
//Биты 0-2 - размер палитры, если бит 7 - ноль, то всё зануляется
//Вот это дело можно оптимизировать, смотря какое количество цветов
Flags := Flags or $80;
Flags := Flags or $40 or $20 or $10;
Flags := Flags or $08 xor $08;
Flags := Flags or $04 or $02 or $01;
WriteFile(F, Flags, SizeOf(Byte), Bytes, nil);
//Пишем номер цвета фона, 1 байт
//Если при этом в самом первом расширении управления графикой включена прозрачность
//То этот цвет считается прозрачным
//Пускай номер цвета фона - белый
//Рекомендуется ставить первые два цвета в палитре - чёрный и белый
Flags := $01;
WriteFile(F, Flags, SizeOf(Byte), Bytes, nil);
//Пишем зарезервированный флаг, который обычно ставят в ноль, 1 байт
Flags := $00;
WriteFile(F, Flags, SizeOf(Byte), Bytes, nil);
//Пишем глобальную палитру
//Для этого соберём все цвета с картинки (предполодим, что вначале их у нас меньше 254)
//Не забываем, первый и второй цвета - чёрный и белый
FillChar(Colors, SizeOf(Colors), 0);
n := 2;
Colors[n, red] := $ff;
Colors[n, green] := $ff;
Colors[n, blue] := $ff;
for i := 0 to Image1.Height - 1 do
begin
for j := 0 to Image1.Width - 1 do
begin
Flags := 0;
for k := 1 to n do
begin
if Colors[k, red] + Colors[k, green] shl 8 + Colors[k, blue] shl 16 = Image1.Canvas.Pixels[j, i] then
begin
Flags := 1;
Break;
end;
end;
if Flags = 0 then
begin
n := n + 1;
Colors[n, red] := (Image1.Canvas.Pixels[j, i] and $ff);
Colors[n, green] := (Image1.Canvas.Pixels[j, i] and $ff00) div $100;
Colors[n, blue] := (Image1.Canvas.Pixels[j, i] and $ff0000) div $10000;
end;
end;
end;
for i := 1 to 256 do
begin
WriteFile(F, Colors[i, red], SizeOf(Byte), Bytes, nil);
WriteFile(F, Colors[i, green], SizeOf(Byte), Bytes, nil);
WriteFile(F, Colors[i, blue], SizeOf(Byte), Bytes, nil);
end;
//Пишем символ запятой, 1 байт
Flags := Ord(',');
WriteFile(F, Flags, SizeOf(Byte), Bytes, nil);
//Пишем левый угол логического экрана - 2 байта
w := 0;
WriteFile(F, w, SizeOf(Word), Bytes, nil);
//Пишем верхний угол логического экрана - 2 байта
w := 0;
WriteFile(F, w, SizeOf(Word), Bytes, nil);
//Пишем длину изображения, 2 байта
WriteFile(F, Image1.Width, SizeOf(Word), Bytes, nil);
//Пишем высоту изображения, 2 байта
WriteFile(F, Image1.Height, SizeOf(Word), Bytes, nil);
//Пишем флаги
//Бит 7 - наличие локальной палитры
//Бит 6 - черезстрочная или обычная развёртка
//Хз, какое состояние флага за что отвечает
//Предположим, что
//0 - обычная развёртка
//1 - черезстрочная
//По сути качество картинки, нам нужно всегда максимальное
//Бит 5 - флаг сортировки палитры, обычно стоит ноль
//Биты 3-4 - стоят зарезервированные нули
//Биты 0-2 - размер локальной палитры
//Вот это дело можно оптимизировать, смотря какое количество цветов
Flags := Flags or $80 xor $80;
Flags := Flags or $40 xor $40;
Flags := Flags or $20 xor $20;
Flags := Flags or $10 xor $10 or $08 xor $08;
Flags := Flags or $04 or $02 or $01;
WriteFile(F, Flags, SizeOf(Byte), Bytes, nil);
//Описываем изображение
//Пишем начальный размер LZW-кода, 1 байт
//Равен глубине цвета картинки
//За исключением двухцветных, когда MC равен не 1, а 2
Flags := $08;
WriteFile(F, Flags, SizeOf(Byte), Bytes, nil);
//Пишем размер субблока данных, 1 байт
//Вначале идут 255, последний - любой от 1 до 255
//Если предыдущие пункты кое-как понятны, то тут запарка...
//Пошли копать структуру изображения
CloseHandle(F);
end;
begin
Clicked := False;
end.
