I'm trying to execute an sql query asynchronously. I've checked the example code from http://docwiki.embarcadero.com/RADStudio/XE5/en/Asynchronous_Execution_(FireDAC)
and also the example project from directory
..Samples\Object Pascal\Database\FireDAC\Samples\Comp Layer\TFDQuery\ExecSQL\Async
and I think I got the logic inside. But there is one problem - the event QueryAfterOpen never executes and my TDataSource remains always Nil (because it gets Nil inside QueryBeforeOpen - this event executes always). This is all the code from my unit :
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes,
Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs, FireDAC.Stan.Intf,
FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf,
FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys,
FireDAC.VCLUI.Wait, FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, FireDAC.DApt,
Vcl.StdCtrls, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
FireDAC.Phys.MySQLDef, FireDAC.Phys.MySQL;
type
TForm1 = class(TForm)
Button1: TButton;
FDPhysMySQLDriverLink1: TFDPhysMySQLDriverLink;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
procedure Query1BeforeOpen(DataSet: TDataSet);
procedure Query1AfterOpen(DataSet: TDataSet);
procedure FormDestroy(Sender: TObject);
private
{ Private declarations }
Connection1: TFDConnection;
Query1: TFDQuery;
DataSource1: TDataSource;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
QueryFinished: Boolean;
begin
with Query1 do begin
SQL.Text := 'SELECT field1 FROM test_table WHERE idpk=1';
AfterOpen := Query1AfterOpen;
BeforeOpen := Query1BeforeOpen;
ResourceOptions.CmdExecMode := amAsync;
QueryFinished := False;
Open;
repeat
Sleep(100);
if Command.State = csPrepared then begin
// A command is prepared. A result set is not accessible.
// TmpInteger := Query1.FieldByName('field1').AsInteger;
end
else if Command.State = csOpen then begin // A command execution
// is finished. A result set is accessible and not yet fully fetched.
if DataSource1.DataSet <> Nil then begin
// this code never executes because Query1AfterOpen never executes and
// DataSource1.DataSet remains always Nil !!!
QueryFinished := True;
end;
end;
until ((QueryFinished) OR (DataSource1.DataSet <> Nil));
end;
end;
procedure TForm1.FormCreate(Sender: TObject);
var
SQLConnParams: string;
begin
SQLConnParams := ''; // sql connection parameters removed from here from security
// issues, assume they are correct
Connection1 := TFDConnection.Create(Nil);
Connection1.Params.Text := SQLConnParams;
Query1 := TFDQuery.Create(Nil);
Query1.Connection := Connection1;
DataSource1 := TDataSource.Create(Nil);
DataSource1.DataSet := Query1;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
DataSource1.Free;
Query1.Free;
Connection1.Free;
end;
procedure TForm1.Query1AfterOpen(DataSet: TDataSet);
begin
DataSource1.DataSet := Query1;
Query1.AfterOpen := Nil;
//Query1.ResourceOptions.CmdExecMode := amBlocking;
end;
procedure TForm1.Query1BeforeOpen(DataSet: TDataSet);
begin
DataSource1.DataSet := Nil;
end;
end.
Apparently the code inside the repeat .. until .. loop is infinite unless someone terminates the program. What am I missing in order to execute the code inside Query1AfterOpen (or use another event instead) so I can access the result set after the TFDQuery has finished working ?
Those asynchronous events are synchronized with the main thread via the message loop. As long as you stay inside the Button1Click event no new messages can be handled. Thus the AfterOpen event is stuck inside the message loop.
I don't know what you are trying to achieve, but you should consider placing the relevant code in the AfterOpen event. The repeat-until clause somehow counterfeits the purpose of that async execution.
Related
I have old Delphi (XE6) project for a Firebird 2.5 database with IBX (IBExpress) components, where two IBDatabases controlled by one IBTransaction. When I commit (or rollback) the active transaction, modifications in both databases are committed (or rolled back) too. Firebird server support multidatabase transaction, see: 3.7. Multi-database applications in the Firebird documentation
Now, I need this function with Delphi XE6 FireDAC components, but when I try to run ExecSQL or Open select in both FDQuery, method Prepare in one FDQuery crashes with error:
[FireDAC][Phys][FB]-343. Cannot set default transaction
I was looking for a solution, but my problem is very rare, I did not find anything. FireDAC components support AutoStart and AutoStop transactions, but I have disabled this support, I want to manage the transactions manually. To test, you need two Firebird databases and use any SQL statement.
My test project, only Form and one Button:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, FireDAC.Stan.Intf,
FireDAC.Stan.Option, FireDAC.Stan.Error, FireDAC.UI.Intf, FireDAC.Phys.Intf,
FireDAC.Stan.Def, FireDAC.Stan.Pool, FireDAC.Stan.Async, FireDAC.Phys,
FireDAC.Stan.Param, FireDAC.DatS, FireDAC.DApt.Intf, FireDAC.DApt,
FireDAC.Phys.IBBase, FireDAC.Phys.FB, Data.DB, FireDAC.Comp.DataSet,
FireDAC.Comp.Client, FireDAC.VCLUI.Wait, FireDAC.Comp.UI;
type
TForm1 = class(TForm)
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FDTranBeforeCommit(Sender: TObject);
procedure FDTranBeforeRollback(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.Button1Click(Sender: TObject);
var
FDGUIxWaitCur: TFDGUIxWaitCursor;
FDPhysFBDriv: TFDPhysFBDriverLink;
FDCon1: TFDConnection;
FDCon2: TFDConnection;
FDTrx: TFDTransaction;
FDQry1: TFDQuery;
FDQry2: TFDQuery;
begin
FDGUIxWaitCur := TFDGUIxWaitCursor.Create(nil);
FDPhysFBDriv := TFDPhysFBDriverLink.Create(nil);
FDPhysFBDriv.VendorLib := 'C:\Program Files\Firebird\Firebird_2_5\WOW64\fbclient.dll'; { 32 bit applications on 64 bit Firebird }
FDCon1 := TFDConnection.Create(nil);
FDCon2 := TFDConnection.Create(nil);
FDTrx := TFDTransaction.Create(nil);
FDQry1 := TFDQuery.Create(nil);
FDQry2 := TFDQuery.Create(nil);
try
try
FDTrx.Options.AutoCommit := False;
FDTrx.Options.AutoStart := False;
FDTrx.Options.AutoStop := False;
FDTrx.BeforeCommit := FDTranBeforeCommit;
FDTrx.BeforeRollback := FDTranBeforeRollback;
FDCon1.TxOptions.AutoCommit := False;
FDCon1.TxOptions.AutoStart := False;
FDCon1.TxOptions.AutoStop := False;
FDCon1.Params.Clear;
FDCon1.Params.Add('DriverID=FB');
FDCon1.Params.Add('Database=c:\a\dbone.fdb');
FDCon1.Params.Add('Server=LOCALHOST/3050');
FDCon1.Params.Add('Protocol=TCPIP');
FDCon1.Params.Add('user_name=NAME');
FDCon1.Params.Add('password=passw');
FDCon1.Params.Add('lc_ctype=WIN1250');
FDCon2.TxOptions.AutoCommit := False;
FDCon2.TxOptions.AutoStart := False;
FDCon2.TxOptions.AutoStop := False;
FDCon2.Params.Clear;
FDCon2.Params.Add('DriverID=FB');
FDCon2.Params.Add('Database=c:\a\dbtwo.fdb');
FDCon2.Params.Add('Server=LOCALHOST/3050');
FDCon2.Params.Add('Protocol=TCPIP');
FDCon2.Params.Add('user_name=NAME');
FDCon2.Params.Add('password=passw');
FDCon2.Params.Add('lc_ctype=WIN1250');
FDCon1.Transaction := FDTrx;
FDCon2.Transaction := FDTrx;
FDQry1.Connection := FDCon1;
FDQry1.Transaction := FDTrx;
FDQry2.Connection := FDCon2;
FDQry2.Transaction := FDTrx;
FDCon1.Open;
FDCon2.Open;
if FDTrx.Active then
ShowMessage('trx active');
if not FDTrx.Active then
FDTrx.StartTransaction;
if FDTrx.Active then
ShowMessage('trx active');
FDQry2.Close;
FDQry2.SQL.Text := 'select count(id) from table';
FDQry2.Prepare;
FDQry2.Open;
ShowMessage(Format('DBTwo table records count %d',[FDQry2.Fields[0].AsInteger]));
FDQry2.Close;
if FDTrx.Active then
ShowMessage('trx active');
FDQry1.Close;
FDQry1.SQL.Text := 'select count(id) from table';
FDQry1.Prepare; { An error appears here }
FDQry1.Open;
ShowMessage(Format('DBOne table records count %d',[FDQry1.Fields[0].AsInteger]));
FDQry1.Close;
if FDTrx.Active then
FDTrx.Commit;
except on E: Exception do
begin
ShowMessage(e.Message);
if FDTrx.Active then
FDTrx.Rollback;
end;
end;
finally
FDQry2.Close;
FDQry1.Close;
FDCon2.Close;
FDCon1.Close;
FDQry2.Free;
FDQry1.Free;
FDTrx.Free;
FDCon2.Free;
FDCon1.Free;
FDPhysFBDriv.Free;
FDGUIxWaitCur.Free;
end;
end;
procedure TForm1.FDTranBeforeCommit(Sender: TObject);
begin
ShowMessage('Trx BeforeCommit');
end;
procedure TForm1.FDTranBeforeRollback(Sender: TObject);
begin
ShowMessage('Trx BeforeRollback');
end;
end.
I have a DataModule shared by several forms and in that I built a procedure to processing a TFDMemtable passed as parameter. In order to process it I must to disable the events AfterPost and AfterDelete and when conclude processing I have to enable them back. I'm not suceeding in enable them back, because I can't get the actual name of these events in a form "actualnameAfterpost".
I've tried :
pMemTable.AfterPost := #pMemTable.AfterPost ; // Result ==> compile error
pMemTable.AfterPost := addr(pMemTable.AfterPost) ; // Result ==> compile error
pMemTable.AfterPost := MethodAddress(Pmemtable.ClassName +'AfterPost'); //
Result ==> compile error
This is the main code :
procedure UpdateMemtable (var pMemTable : TFDmemtable);
begin
pMemTable.AfterPost := nil;
pMemTable.AfterDelete := nil;
TRY
with pMemTable do
begin
{ code to process pMemtable }
end;
FINALLY
pMemTable.AfterPost := ["actualmemtablenameAfterPost" ??];
pMemTable.AfterDelete := ["actualmemtablenameAfterDelete" ??];
END;
end;
Thanks all !
Both events are of type TDataSetNotifyEvent. Use two local variables of this type to hold the events temporarily.
To disable the events, save them to the temporary variables and then nil them.
After you have done the manipulation restore the actual events from the temporary vars.
procedure UpdateMemtable (var pMemTable : TFDmemtable);
var
tmpAfterPost,
tmpAfterDelete: TDataSetNotifyEvent
begin
tmpAfterPost := pMemTable.AfterPost;
tmpAfterDelete := pMemTable.AfterDelete;
pMemTable.AfterPost := nil;
pMemTable.AfterDelete := nil;
TRY
with pMemTable do
begin
{ code to process pMemtable }
end;
FINALLY
pMemTable.AfterPost := tmpAfterPost;
pMemTable.AfterDelete := tmpAfterDelete;
END;
end;
You need just to write your procedures and then assign them as
...
private
{ Private declarations }
procedure MyAfterPost(ADataSet: TDataSet);
procedure MyAfterDelete(ADataSet: TDataSet);
...
procedure TForm1.MyAfterDelete(ADataSet: TDataSet);
begin
ShowMessage('After Delete Fired');
end;
procedure TForm1.MyAfterPost(ADataSet: TDataSet);
begin
ShowMessage('After Post Fired');
end;
....
pMemTable.AfterPost:= MyAfterPost;
pMemTable.AfterDelete:= MyAfterDelete;
Here is a simple sample to help you understand, just run it and see what's happening
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, FireDAC.Stan.Intf, FireDAC.Stan.Option,
FireDAC.Stan.Param, FireDAC.Stan.Error, FireDAC.DatS, FireDAC.Phys.Intf,
FireDAC.DApt.Intf, Data.DB, FireDAC.Comp.DataSet, FireDAC.Comp.Client,
Vcl.ExtCtrls, Vcl.DBCtrls, Vcl.Grids, Vcl.DBGrids;
type
TForm1 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
{ Private declarations }
pMemTable: TFDMemTable;
Ds: TDataSource;
Grid: TDBGrid;
Navigator: TDBNavigator;
procedure MyAfterPost(ADataSet: TDataSet);
procedure MyAfterDelete(ADataSet: TDataSet);
procedure GridTitleClick(Column: TColumn);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
// Free all
pMemTable.Free;
Ds.Free;
Navigator.Free;
Grid.Free;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
// Create the pMemTable
pMemTable:= TFDMemTable.Create(Nil);
with pMemTable do
begin
FieldDefs.Add('Column1', ftInteger);
FieldDefs.Add('Column2', ftInteger);
CreateDataSet;
// Assign the procedures
AfterPost:= MyAfterPost;
AfterDelete:= MyAfterDelete;
end;
// Create DataSource
Ds:= TDataSource.Create(Self);
Ds.DataSet:= pMemTable;
// Create DBNavigator
Navigator:= TDBNavigator.Create(Self);
with Navigator do
begin
Align:= alTop;
Parent:= Self;
DataSource:= Ds;
end;
// Create DBGrid
Grid:= TDBGrid.Create(Self);
with Grid do
begin
Align:= alClient;
Parent:= Self;
DataSource:= Ds;
OnTitleClick:= GridTitleClick;
end;
//
Self.Width:= 250;
Self.Height:= 250;
Self.BorderStyle:= bsDialog;
Self.Position:= poScreenCenter;
end;
procedure TForm1.GridTitleClick(Column: TColumn);
begin
{
The events now is enabled on creation, if you click on "Column1" title
then you disable them, if you click on "Column2" title, you enable them again.
}
if Column.Index = 0 then
begin
pMemTable.AfterPost:= nil;
pMemTable.AfterDelete:= nil;
end
else
begin
pMemTable.AfterPost:= MyAfterPost;
pMemTable.AfterDelete:= MyAfterDelete;
end;
end;
procedure TForm1.MyAfterDelete(ADataSet: TDataSet);
begin
// You will see this message after post
ShowMessage('After Delete Fired');
end;
procedure TForm1.MyAfterPost(ADataSet: TDataSet);
begin
// You will see this message after delete
ShowMessage('After Post Fired');
end;
end.
Finally, I suggest to visit those pages and read them:
Data.DB.TDataSetNotifyEvent
Creating Events - Overview
I am trying to create a data aware control. I have a TFieldDataLink object with a DataSource and Field hooked up. Everything seemed to be going OK until I tried to edit the value.
I am using the OnDataChange and OnUpdateData events for the TFieldDataLink. It looks like I need to call TFieldDataLink.Edit if I want the OnUpdateData event to be called before moving to a new record or posting. In the sample code below am trying to call .Edit in the OnExit field of the control if changes were made. In my actual app the control consists of several DevExpress lookup combo boxes and I am trying to call .Edit in OnEditValueChanged.
My problem is the call to TFieldDataLink.Edit causes the OnDataChange event to fire again. That forces a reload of my edit with the original value. If I make a second change after the Dataset is already in edit mode then a OnDataChange event is not fired.
Here is a test unit I that has everything on one form. In my actual app this is split out into a more complicated component.
When should I be calling .Edit without getting OnUpdateData to change? I know I could set a member variable to stop the reload or unhook the events before calling .Edit. It feels like there is something I don't understand about the TFieldDataLink object and I should not need to resort to those tricks.
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, uADStanIntf, uADStanOption, uADStanParam, uADStanError,
uADDatSManager, uADPhysIntf, uADDAptIntf, Data.DB, uADCompDataSet, uADCompClient, Vcl.StdCtrls,
Vcl.DBCtrls, Vcl.Mask, Vcl.ExtCtrls, Vcl.Grids, Vcl.DBGrids;
type
TForm1 = class(TForm)
Edit1: TEdit;
DataSource1: TDataSource;
ADMemTable1: TADMemTable;
ADMemTable1test: TStringField;
Button1: TButton;
DBEdit1: TDBEdit;
DBGrid1: TDBGrid;
DBNavigator1: TDBNavigator;
procedure FormCreate(Sender: TObject);
procedure Edit1Exit(Sender: TObject);
procedure FormDestroy(Sender: TObject);
private
FMyDataLink: TFieldDataLink;
procedure MyDataChange(Sender: TObject);
procedure MyUpdateData(Sender: TObject);
public
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
AdMemTable1.CreateDataSet;
FMyDataLink := TFieldDataLink.Create();
FMyDataLink.DataSource := DataSource1;
FMyDataLink.FieldName := 'test';
FMyDataLink.OnDataChange := MyDataChange;
FMyDataLink.OnUpdateData := MyUpdateData;
AdMemTable1.Append;
AdMemTable1.FieldByName('test').AsString := 'my test';
AdMemTable1.Post;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FMyDataLink.OnDataChange := nil;
FMyDataLink.OnUpdateData := nil;
FMyDataLink.Free;
end;
procedure TForm1.Edit1Exit(Sender: TObject);
begin
if Edit1.Modified = true then
begin
FMyDataLink.Edit;
FMyDataLink.Modified;
end;
end;
procedure TForm1.MyDataChange(Sender: TObject);
begin
Edit1.Text := FMyDataLink.Field.AsString;
Edit1.Modified := false;
end;
procedure TForm1.MyUpdateData(Sender: TObject);
begin
FMyDataLink.Field.AsString := Edit1.Text
end;
end.
TFieldDataLink.Edit only sets the DataSource in editing state (just like DataSet.Edit). You do not need it here, but example usage could be:
procedure TMyCustomControl.DoPaste;
begin
FMyDataLink.Edit;
inherited DoPaste;
FMyDataLink.Modified;
end;
What you want instead on exit of the control is to update the record, if it is modified:
procedure TForm1.Edit1Exit(Sender: TObject);
begin
if Edit1.Modified then
try
FMyDataLink.UpdateRecord;
except
Edit1.SetFocus;
raise;
end;
end;
As for when TFieldDataLink.Modified should be called, that's when you have updated the field value:
procedure TForm1.MyUpdateData(Sender: TObject);
begin
FMyDataLink.Field.AsString := Edit1.Text;
FMyDataLink.Modified;
end;
It's an old question, but for those who are encountering the same problem,
you have to override the data-aware control's KeyPress method and call the FieldDataLink.Edit; after Inherited; if the Key is valid for the input (incl. del/c&p/bs/etc..).
At this point the current data is not yet modified. Calling .Edit later than this point is too late.
Problem:
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass, next code:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants,
System.Classes, Vcl.Graphics, Vcl.Controls, Vcl.Forms, Vcl.Dialogs,
Vcl.StdCtrls, Vcl.ExtCtrls;
type
TFrameClass = class of TFrame;
type
TForm1 = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
procedure FormClose(Sender: TObject; var Action: TCloseAction);
private
FFrame: TFrame;
function StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses Base1Frame, Base2Frame, Base3Frame;
function TForm1.StrShowFrame(FrameClassName: string;
ParentPanel: TWinControl): Boolean;
var
FrameClass: TClass;
// Current Frame (FrameName)
FrameName: string;
begin
Result := False;
??? GetClass is only locality for main form in appl-n
FrameClass := GetClass(FrameClassName);
if FrameClass = nil then
begin
ShowMessageFmt('Class %s not registered', [FrameClassName]);
Result := False;
Exit;
end;
try
begin
LockWindowUpdate(ParentPanel.Handle);
if Assigned(FFrame) then
if FFrame.ClassType = FrameClass then
begin
Result := True;
Exit;
end
else
FFrame.Destroy; // del previus FrameClass
try
FFrame := TFrameClass(FrameClass).Create(nil);
except
on E:Exception do
begin
Result := True;
E.Create(E.Message);
FFrame := nil;
Exit;
end;
end;
FrameName:= FrameClassName;
Delete(FrameName, 1, 1); // T-...
FFrame.Name := Concat(FrameName, '1');
FFrame.Parent := ParentPanel;
FFrame.Align := alClient;
end;
finally
LockWindowUpdate(0);
end;
Result := True;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
StrShowFrame('TFr_Base1', Panel1);
end;
procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
try
if FFrame <> nil then
FFrame.Free
else
ShowMessage('Class not activ');
except
end;
end;
end.
How can I load frame in Form1 or sample container in form ?
FindClass or GetClass is only locality for main form appl-n
I need (maybe) string globaly elemental for TFrameClass.
GetClass() and FindClass() are not local to the MainForm, they are global to the entire RTL as a whole. Any unit can call RegisterClass() and have that class be accessible to any other unit that shares the same instance of the RTL. That last part is important. A DLL cannot register a class that the EXE uses (and vice versa), unless both projects are compiled with Runtime Packages enabled so they share a single RTL instance.
Just learning some OpenGL with delphi and trying something simple but not getting a result, I belive i should get a dark green form. But when i run this i get nothing. No errors either. maybe missing something?
unit First1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls,OpenGL, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls;
type
TForm2 = class(TForm)
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure FormPaint(Sender: TObject);
private
{ Private declarations }
GLContext : HGLRC;
ErrorCode: GLenum;
public
{ Public declarations }
end;
var
Form2: TForm2;
implementation
{$R *.dfm}
procedure TForm2.FormCreate(Sender: TObject);
var
pfd: TPixelFormatDescriptor;
FormatIndex: integer;
begin
fillchar(pfd,SizeOf(pfd),0);
with pfd do
begin
nSize := SizeOf(pfd);
nVersion := 1; {The current version of the desccriptor is 1}
dwFlags := PFD_DRAW_TO_WINDOW or PFD_SUPPORT_OPENGL;
iPixelType := PFD_TYPE_RGBA;
cColorBits := 24; {support 24-bit color}
cDepthBits := 32; {depth of z-axis}
iLayerType := PFD_MAIN_PLANE;
end; {with}
FormatIndex := ChoosePixelFormat(Canvas.Handle,#pfd);
SetPixelFormat(Canvas.Handle,FormatIndex,#pfd);
GLContext := wglCreateContext(Canvas.Handle);
wglMakeCurrent(Canvas.Handle,GLContext);
end; {FormCreate}
procedure TForm2.FormDestroy(Sender: TObject);
begin
wglMakeCurrent(Canvas.Handle,0);
wglDeleteContext(GLContext);
end;
procedure TForm2.FormPaint(Sender: TObject);
begin
{background}
glClearColor(0.0,0.4,0.0,0.0);
glClear(GL_COLOR_BUFFER_BIT);
{error checking}
errorCode := glGetError;
if errorCode<>GL_NO_ERROR then
raise Exception.Create('Error in Paint'#13+
gluErrorString(errorCode));
end;
end.
Since you request a single buffered context, you must call glFinish at the end of the rendering code, to commit your drawing commands to the implementation. However I strongly suggest you switch to using a double buffered context and instead of glFinish-ing you issue a wglSwapBuffers which implies a finish.