procedure TForm1.Blah;
var
hMemRC, hOldRC: HGLRC;
FormatIndex: Integer;
pfd: TPixelFormatDescriptor;
poBits: Pointer;
rctAux: TRect;
dbRatio: Double;
ptPrn, ptDIB: TPoint;
bmpAux: TBitmap;
bmiAux: BITMAPINFO;
hhDc, hDIB, hMemDC, hOldDc: HDC;
begin
// 1. Determine the DIB size
rctAux := pnlDraw.BoundsRect;
with rctAux do
dbRatio := (Bottom - Top) / (Right - Left);
ptPrn := Point(GetDeviceCaps(Printer.Handle, HORZRES),
GetDeviceCaps(Printer.Handle, VERTRES));
if ptPrn.Y > (dbRatio * ptPrn.X) then
ptDIB := Point(ptPrn.X, Trunc(dbRatio * ptPrn.X))
else
ptDIB := Point(Trunc(ptPrn.Y / dbRatio), ptPrn.Y);
while (ptDIB.X * ptDIB.Y) > 20E6 do
ptDIB := Point(ptDIB.X div 02, ptDIB.Y div 02);
//ShowMessage(Format('%d x %d = %6.2f MB', [ptDib.X, ptDib.Y,
//ptDIB.X * ptDIB.Y / (1024 * 1024)]));
// 2. Create the DIB section
with bmiAux.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := ptDIB.X;
biHeight := ptDIB.Y;
biPlanes := 01;
biBitCount := 24;
biCompression := BI_RGB;
biSizeImage := 03 * ptDIB.X * ptDIB.Y
end;
hhDC := GetDC(pnlDraw.Handle);
hDIB := CreateDIBSection(hhDc, bmiAux, DIB_RGB_COLORS, poBits, 00, 00);
ReleaseDC(pnlDraw.Handle, hhDc);
// 3. Create memory DC and associate it with the DIB
hMemDC := CreateCompatibleDC(00);
if hMemDC = 00 then
begin
DeleteObject(hMemDC);
hMemDC := 00;
Exit
end;
SelectObject(hMemDC, hDIB);
// 4. Setup memory DC's pixel
FillChar(pfd, SizeOf(pfd), 00);
with pfd do
begin
nSize := SizeOf(pfd);
nVersion := 1;
dwFlags := PFD_DRAW_TO_BITMAP or PFD_SUPPORT_OPENGL or
PFD_STEREO_DONTCARE;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 32; // support 24-bit color
cDepthBits := 16; // depth of z-axis
iLayerType := PFD_MAIN_PLANE;
end;
FormatIndex := ChoosePixelFormat(hMemDC, @pfd);
if not SetPixelFormat(hMemDC, FormatIndex, @pfd) then
begin
DeleteObject(hDIB);
hDIB := 00;
DeleteDC(hMemDC);
hMemDC := 00;
Exit
end;
// 5. Create memory RC
hMemRC := wglCreateContext(hMemDC);
if hMemRC = 00 then
begin
DeleteObject(hDIB);
hDIB := 00;
DeleteDC(hMemDC);
hMemDC := 00;
Exit
end;
// 6. Store old DC and RC
hOldDc := wglGetCurrentDC;
hOldRC := wglGetCurrentContext;
// 7. Make the memory RC current
wglMakeCurrent(hMemDC, hMemRC);
// 8. Set OpenGL state for memory RC
glClearColor(1.0, 1.0, 1.0, 0.0);
glMatrixMode(GL_PROJECTION);
glOrtho(-DB_LIM, DB_LIM, -DB_LIM, DB_LIM, -DB_LIM, DB_LIM);
glEnable(GL_DEPTH_TEST);
glMatrixMode(GL_MODELVIEW);
glLoadIdentity;
glViewport(00, 00, ptDIB.X, ptDIB.Y);
// 9. Draw the scene
mp_pglDraw;
// 10. Release memory RC and restore the old DC and RC
wglMakeCurrent(00, 00);
wglDeleteContext(hMemRC);
wglMakeCurrent(hOldDc, hOldRC);
// 11. Copy and save the image
bmpAux := TBitmap.Create;
bmpAux.Width := ptDIB.X;
bmpAux.Height := ptDIB.Y;
StretchDIBits(bmpAux.Canvas.Handle, 00, 00, bmpAux.Width, bmpAux.Height,
00, 00, bmiAux.bmiHeader.biWidth, bmiAux.bmiHeader.biHeight, poBits, bmiAux,
DIB_RGB_COLORS, SRCCOPY);
bmpAux.SaveToFile('A.bmp');
// 12. Release memory
DeleteObject(hDIB);
hDIB := 00;
DeleteDC(hMemDC);
hMemDC := 00;
hOldDc := 00
end;
DIB render with Delphi
Hi ALL,
I'm using Delphi 6.0 under Windows XP Home Edition and want
to render a OpenGL scene to a DIB and then, save it to a file
or send it to a printer.
I've tried the code below, but get stuck at the line
"if not SetPixelFormat(hMemDC, FormatIndex, @pfd) then"
because the SetPixelFormat function fail.
Can anyone help me or even show me a better way to do this?
[]'s
Luiz
This topic is closed to new replies.
Advertisement
Popular Topics
Advertisement