Показывайте код. Целиком выложите проект
Вот код через OpenGL
- Код: Выделить всё
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs,OpenGL, StdCtrls;
type
TForm1 = class(TForm)
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
dc:hdc;
// hrc:HGLRC;
BitMap : TBitMap;
implementation
{$R *.dfm}
procedure SetDCPixelFormat (hdc : HDC);
var
pfd : TPixelFormatDescriptor;
nPixelFormat : Integer;
begin
//FillChar(pfd, SizeOf (pfd), 0);
pfd.dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL or PFD_DOUBLEBUFFER;
nPixelFormat :=ChoosePixelFormat (hdc, @pfd);
SetPixelFormat(hdc, nPixelFormat, @pfd);
wglMakeCurrent(hDC, wglCreateContext(hDC));
end;
procedure MakeDC(DC:HWND);
begin
SetDCPixelFormat(DC);
glViewport(0,0,form1.ClientWidth,form1.ClientHeight);
glMatrixMode(GL_PROJECTION);
glLoadIdentity;
glOrtho( 0, form1.ClientWidth,form1.ClientHeight,0, -1, 1 );
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Form1.Width:=1024;
Form1.Height:=768;
DC:=GetDC(Handle);
MakeDC(DC);
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
wglMakeCurrent(0, 0);
//wglDeleteContext(hrc);
ReleaseDC(Handle, DC);
DeleteDC(DC);
end;
procedure WritePoint(DC:HDC; x,y:integer;ic:TColorREF);
var
r,g,b:DWORD;
begin
r:=GetRValue(ic);
g:=GetGValue(ic);
b:=GetBValue(ic);
glPointSize(1);
glColor3f(r,g,b);
glBegin(GL_POINTS);
glVertex2f(x,y);
glEnd;
end;
procedure TForm1.Button1Click(Sender: TObject);
var
i,j,t:integer;
begin
t:=GetTickCount;
for i:=0 to form1.ClientWidth do begin
for j:=0 to form1.ClientHeight do begin
WritePoint(DC,i,j,clred);
end;
end;
t:=GetTickCount-t;
Form1.Caption :=IntToStr(t)+' ms';
SwapBuffers(DC);
end;
end.
Теперь вопрос про отрисовку через SetDIBitsToDevice
Alex2013
Зачем вообще на точках зацикливаться ?
Потому что хочется перекомпилировать одну программу, в которой используется SetPixel, но чтобы можно было отрисовку делать универсальной,
используется
- Код: Выделить всё
Type MyPixel=procedure(DC:HDC;x,y:integer;ic:TColorRef);
var
PPutPixel:MyPixel;
Впрочем, полный код ниже.
вопрос: как правильно вынести отрисовку отдельно, а не для каждого пиксела?
Верно ли задавать размерность массива wth:=1; hth:=1; SetLength(bBytes, wth*hth)? Или надо по размеру изображения
- Код: Выделить всё
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls,math;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
Type MyPixel=procedure(DC:HDC;x,y:integer;ic:TColorRef);
var
Form1: TForm1;
PPutPixel:MyPixel;
fwth,fhth:integer;
DC:HDC;
implementation
{$R *.dfm}
procedure draw3(DC:HDC;x,y:integer;ic:TColorRef);
var
bBytes: array of longint;
yc, xc: Longint;
bi: BITMAPINFO;
wth,hth:integer;
begin
wth:=1; hth:=1;
with bi.bmiHeader do begin
biSize := sizeof(bi);
biBitCount := 32;
biCompression := BI_RGB;
biPlanes := 1;
biWidth := wth;
biHeight := hth;
end;
SetLength(bBytes, wth*hth);
for xc:=Low(bBytes) to High(bBytes) do begin
bBytes[xc] :=clBlue;
end; // xc
SetDIBitsToDevice
(dc,
x,
y,
bi.bmiHeader.biWidth,
bi.bmiHeader.biHeight,
0, 0, 0,
bi.bmiHeader.biHeight,
@bBytes[0],
bi, DIB_RGB_COLORS);
end;
procedure TForm1.Button1Click(Sender: TObject);
var i,j:integer;
begin
DC:=GetDC(Form1.Handle);
PPutPixel:=Draw3;
for i:=0 to fwth-1 do begin
for j:=0 to fhth-1 do begin
PPutPixel(DC,i,j,clred);
end;
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
fwth:=form1.Width;
fhth:=form1.Height;
end;
end.