did when pressing button select all the lines in dbgrid, can I select all the lines when ctrl + a is pressed?
function GridSelectAll(Grid: TDBGrid): Longint;
begin
Result := 0;
Grid.SelectedRows.Clear;
with Grid.Datasource.DataSet do
begin
First;
DisableControls;
try
while not EOF do
begin
Grid.SelectedRows.CurrentRowSelected := True;
inc(Result);
Next;
end;
finally
EnableControls;
end;
end;
end;
procedure TForm2.btn13Click(Sender: TObject);
begin
GridSelectAll(dbgrd1);
end;
procedure TForm1.FormKeyDown(Sender: TObject; var Key: Word; Shift: TShiftState); begin if (ssCtrl in Shift) and (Key = $41) then
then GridSelectAll(dbgrd1); end;
Related
I"m converting an oracle stored procedure to Postgres. Oracle uses an out parameter
O_MTG_CURSOR OUT SYS_REFCURSOR
that is included as a parameter to call to another stored procedure:
GET_MTG(O_MTG_CURSOR ,O_SQLCODE,O_SQLMSG );
When I try to call the same stored procedure in postgres, the cursor is null
CALL GET_MTG(O_MTG_CURSOR,O_SQLCODE,O_SQLMSG );
Is there any way to pass the cursor as a parameter and have it return the results from the called stored procedure?
This Oracle procedure makes 10 different calls to other stored procedures and fills the output cursors with the results of those calls. SO I need to be able to repeat this in postgres.
Minimal code that shows the problem
CREATE OR REPLACE PROCEDURE get_mtg (
i_mtg_id text,
i_lookup_type text,
i_agd text,
i_timestamp timestamp without time zone,
INOUT o_mtg_cursor refcursor DEFAULT NULL::refcursor,
INOUT o_dir_ocursor refcursor DEFAULT NULL::refcursor,
INOUT o_error_code integer DEFAULT 0,
INOUT o_error_msg character varying DEFAULT 'SUCCESS'::character varying)
LANGUAGE 'plpgsql'
AS $BODY$
DECLARE
lookup_type_missing CHARACTER VARYING := 'lookup_type_missing';
mtg_id_missing CHARACTER VARYING := 'mtg_id_missing';
mtg_not_found CHARACTER VARYING := 'mt_not_found';
system_exception CHARACTER VARYING := 'system_exception';
dir_not_found CHARACTER VARYING := 'dir_not_found';
data_is_in_flux_state CHARACTER VARYING := 'data_is_in_flux_state';
l_agd_nbr CHARACTER VARYING(20);
BEGIN
RAISE NOTICE USING MESSAGE = '[GET_MTG] START';
o_error_code := 0;
o_error_msg := CONCAT_WS('', 'SUCESSFUL');
IF i_lookup_type IS NULL THEN
/* RAISE THE EXCEPTION THAT LOOK UP TYPE CANNOT BE NULL */
RAISE USING detail = lookup_type_missing, hint = 1;
ELSIF i_mtg_id IS NULL THEN
/* RAISE THE EXCEPTION THAT MTG_ID CANNOT BE NULL. */
RAISE USING detail = mtg_id_missing, hint = 1;
ELSE
RAISE NOTICE USING MESSAGE = '[GET_MTG] GET THE OUT PUT RESULT SET - START';
CALL GET_MTG_DIR(o_dir_cursor,O_ERROR_CODE,O_ERROR_MSG );
CALL GET_MTG_DTL(o_mtg_cursor,O_ERROR_CODE,O_ERROR_MSG );
END IF;
RAISE NOTICE USING MESSAGE = '[GET_MTG] END';
EXCEPTION
WHEN raise_exception THEN
DECLARE
exc$name CHARACTER VARYING;
exc$code CHARACTER VARYING;
BEGIN
GET STACKED DIAGNOSTICS exc$name := pg_exception_detail,
exc$code := pg_exception_hint;
IF exc$name = mtg_id_missing THEN
o_error_code := 101;
o_error_msg := 'ERROR 101.1 : I_MTG_ID CAN NOT BE NULL : RESOLUTION : PASS ''AGD_NBR''';
END IF;
IF exc$name = mtg_not_found THEN
o_error_code := 101;
o_error_msg := CONCAT_WS('', 'ERROR 101.2 : MTG CANNOT BE FOUND : ', i_agd_nbr, ' : RESOLUTION : CHECK THE MTG TABLE');
END IF;
IF exc$name = dir_not_found THEN
o_error_code := 102;
o_error_msg := CONCAT_WS('', 'ERROR 102.1 : DIR IS EMPTY FOR PREF TYPE ''Z'' ON : ', i_mtg_id, ' & ', l_agd_nbr, ' : RESOLUTION : ESCALATE TO SYSADMIN');
END IF;
IF exc$name = data_is_in_flux_state THEN
o_error_code := 501;
o_error_msg := CONCAT_WS('', 'ERROR 501.1 : AGD/DIR/PREF are in flux state - ', i_mtg_id, ', ', l_agd_nbr, ' : RESOLUTION : ESCALATE TO SYSADMIN ');
END IF;
IF exc$name = system_exception THEN
o_error_code := SQLSTATE * - 1;
o_error_msg := CONCAT_WS('', '[GET_MTG] SYSTEM EXCEPTION OCCURED : ', substr(SQLERRM, 1, 200));
END IF;
END;
WHEN no_data_found THEN
o_error_code := 100;
o_error_msg = 'Error: ' || SQLSTATE || ' - ' || SQLERRM;
WHEN others THEN
o_error_code = -1;
o_error_msg = 'Error: ' || SQLSTATE || ' - ' || SQLERRM;
END;
$BODY$;
Thanks for your input but I am not sure I understand your issue. Maybe my answer will help.
Here is an example how you can use refcursor with stored procedures.
Here is the source code:
create table t(x int, t text);
insert into t values(1, 'ONE');
insert into t values(2, 'TWO');
--
create or replace procedure prc3 (inout p_rc refcursor)
as $$
declare
l_rc refcursor;
begin
open l_rc for select * from t;
p_rc = l_rc;
end;
$$ language plpgsql;
--
\echo
--
create or replace procedure prc2 (inout p_rc refcursor)
as $$
declare
l_rc refcursor;
begin
call prc3(l_rc);
p_rc = l_rc;
end;
$$ language plpgsql;
--
\echo
--
create or replace procedure prc1()
as $$
declare
v refcursor;
vx int;
vy text;
begin
call prc2(v);
fetch next from v into vx, vy;
raise notice 'vx=% vy=%', vx, vy;
end
$$ language plpgsql;
--
call prc1();
And here is an execution:
create table t(x int, t text);
CREATE TABLE
insert into t values(1, 'ONE');
INSERT 0 1
insert into t values(2, 'TWO');
INSERT 0 1
create or replace procedure prc3 (inout p_rc refcursor)
as $$
declare
l_rc refcursor;
begin
open l_rc for select * from t;
p_rc = l_rc;
end;
$$ language plpgsql;
CREATE PROCEDURE
create or replace procedure prc2 (inout p_rc refcursor)
as $$
declare
l_rc refcursor;
begin
call prc3(l_rc);
p_rc = l_rc;
end;
$$ language plpgsql;
CREATE PROCEDURE
create or replace procedure prc1()
as $$
declare
v refcursor;
vx int;
vy text;
begin
call prc2(v);
fetch next from v into vx, vy;
raise notice 'vx=% vy=%', vx, vy;
end
$$ language plpgsql;
CREATE PROCEDURE
call prc1();
psql:trc.sql:44: NOTICE: vx=1 vy=ONE
CALL
I've been stressing out for the past few hours trying to get this working and I simply cannot figure it out. Basically it doesn't read anything from my .dat file and when I try to use options 2, 3 or 4 it just comes up with these
.
I've include the .dat file and pascal below. I'm desperate for help.
mytestfile.dat
1
Adele
Pop
2
Hello
ff
Remedy
dd
pascal
program MusicPlayer;
uses TerminalUserInput;
type
TrackRec = record
name: String;
location: String;
end;
// type TrackArray = array of TrackRec;
GenreType = (Pop, Rap, Rock, Classic);
AlbumRec = Record
name: String;
genre: GenreType;
// location: array of TrackRec;
tracks: array of TrackRec;
end;
type AlbumArray = array of AlbumRec;
function ReadGenre(): GenreType;
var
option: Integer;
begin
WriteLn('Press 1 for Pop');
WriteLn('Press 2 for Rap');
WriteLn('Press 3 for Rock');
WriteLn('Press 4 for Classic');
option := ReadInteger('');
while (option<1) or (option>5) do
begin
WriteLn('Please enter a number between 1-4');
option := ReadInteger('');
end;
case option of
1: result := Pop;
2: result := Rap;
3: result := Rock;
else
result := Classic;
end;
end;
procedure NewAlbum(var albums: AlbumArray; var myFile: TextFile);
var
number, i, tracks, y: Integer;
begin
AssignFile(myFile, 'mytestfile.dat');
ReWrite(myFile);
number := ReadInteger('How many albums do you want to make?: ');
WriteLn(myFile, number);
SetLength(albums, number);
for i := Low(albums) to High(albums) do
begin
albums[i].name := ReadString('Enter album name:');
WriteLn(myFile, albums[i].name);
albums[i].genre := ReadGenre();
WriteLn(myFile, albums[i].genre);
tracks := ReadIntegerRange('How many tracks do you want to enter? (max 15)', 0, 15);
WriteLn(myFile, tracks);
SetLength(albums[i].tracks, tracks);
for y := Low(albums[i].tracks) to tracks - 1 do
begin
albums[i].tracks[i].name := ReadString('Track name:');
WriteLn(myFile, albums[i].tracks[i].name);
albums[i].tracks[i].location := ReadString('Track Location:');
WriteLn(myFile, albums[i].tracks[i].location);
end;
end;
Close(myFile);
end;
procedure ReadTrack(count: Integer; var albums: AlbumArray; var myFile: TextFile);
var
i: Integer;
begin
ReadLn(myFile, i);
SetLength(albums[count].tracks, i);
for count := Low(albums[count].tracks) to High(albums[count].tracks) - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
end;
procedure ReadAlbum(var albums: AlbumArray; var myFile: TextFile);
var
albumNumber, tracknumber, count, i: Integer;
begin
AssignFile(myFile, 'mytestfile.dat');
Reset(myFile);
ReadLn(myFile, albumNumber);
SetLength(albums, albumNumber);
for i := Low(albums) to High(albums) do
begin
ReadLn(myFile, albums[i].name);
ReadLn(myFile, albums[i].genre);
ReadLn(myFile, tracknumber);
SetLength(albums[i].tracks, tracknumber);
for count := Low(albums[count].tracks) to tracknumber - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
end;
end;
procedure ReadAlbums(var albums: AlbumArray; var myFile: TextFile);
var
i, number: Integer;
begin
ReadAlbum(albums, myFile);
WriteLn('Album is:');
for i := Low(albums) to High(albums) do
begin
WriteLn((i + 1),'.', albums[i].name);
WriteLn('.', albums[i].genre);
for number := Low(albums[i].tracks) to High(albums[i].tracks) do
begin
WriteLn((number + 1), '', albums[i].tracks[Low(albums[i].tracks)].name);
end;
end;
end;
procedure PlayAlbum (var albums: AlbumArray; var myFile: TextFile);
var
i, number: Integer;
begin
ReadAlbums(albums, myFile);
i := ReadInteger('Please select an album: ');
i := i - 1;
number := ReadIntegerRange('Please select a song from album:', 1, 20);
number := number - 1;
WriteLn('Now playing');
WriteLn('Track selected: ', albums[i].tracks[number].name);
WriteLn('Album: ', albums[i].name);
end;
procedure Update(var albums: AlbumArray; var myFile: TextFile);
var
i: Integer;
begin
ReadAlbums(albums, myFile);
i := ReadInteger('Select an album to update');
i := i - 1;
albums[i].name := ReadString('New Album Name:');
WriteLn('Album has now been updated');
end;
procedure Main();
var
i, count, select, change: Integer;
albums: AlbumArray;
myFile: TextFile;
begin
WriteLn('Please select an option: ');
WriteLn('-------------------------');
WriteLn('1. Read Albums');
WriteLn('2. Display Albums');
WriteLn('3. Select an Album');
WriteLn('4. Update an Album');
WriteLn('5. Exit');
WriteLn('-------------------------');
repeat
i := ReadInteger('Select option for menu:');
case i of
1: ReadAlbum(albums, myFile);
2: ReadAlbums(albums, myFile);
3: PlayAlbum(albums, myFile);
4: Update(albums, myFile);
end;
until i = 5;
end;
begin
Main();
end.
In the ReadAlbum() procedure you have two for loops, an outer one that loops through the albums and an inner one that loops through the tracks. In the latter you have messed up the indexes:
This is the erroneous code:
for count := Low(albums[count].tracks) to tracknumber - 1 do
begin
ReadLn(myFile, albums[count].tracks[i].name);
ReadLn(myFile, albums[count].tracks[i].location);
end;
albums[] should use i as index and tracks[] should use count as index.
Until you get more used to arrays and indexes I suggest you name your variables with a clear meaning, for example:
`NumOfAlbums` in the meaning of how many albums you have
`AlbumIndex` as the index to the albums array
`NumOfTracks` as the number of tracks in an album
`TrackIndex` as the index to the tracks array
It may feel tiresome to write so long names, but you would probably not have made the mistake you did, with the more verbose names.
I Am trying to protect my Tidtcpserver from unknown commands
This is how my Verify commands function looks like
function TConnection.Verfieycmds(const CMSTOV: String): BOOLEAN;
var
CMDSTOVERFIYE : Tstringlist;
I : integer;
CommandFound : Boolean;
begin
Result := False;
CommandFound := False;
if Commandlist <> nil then
begin
CMDSTOVERFIYE := Commandlist.Lock;
try
for I := 0 to CMDSTOVERFIYE.Count - 1 do
begin
if CMSTOV = CMDSTOVERFIYE[I] then
begin
CommandFound := True;
end;
end;
CommandFound := True;
Result := CommandFound;
finally
Commandlist.Unlock;
end;
end;
end;
after adding this check on execute event and after few clients connect the server application freezed and need to be restarted and the exception log were empty
here is my server code
type
TConnection = class(TIdServerContext)
private
{Private}
public
{Public}
OutboundCache: TIdThreadSafeStringList;
Commandlist: TIdThreadSafeStringList;
LastSendRecv: TIdTicks;
Name: String;
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
type
TServobj = class(TForm)
TcpServer: TIdTCPServer;
Panel1: TPanel;
Edit1: TEdit;
Button1: TButton;
Button2: TButton;
procedure TcpServerConnect(AContext: TIdContext);
procedure TcpServerDisconnect(AContext: TIdContext);
procedure TcpServerExecute(AContext: TIdContext);
procedure FormCloseQuery(Sender: TObject; var CanClose: BOOLEAN);
procedure Button1Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
procedure TcpServerListenException(AThread: TIdListenerThread;
AException: Exception);
private
{ Private declarations }
LastUniqueID: Dword;
procedure HandleExceptions(Sender: TObject; E: Exception);
procedure UpdateBindings;
public
{ Public declarations }
end;
var
Servobj: TServobj;
implementation
uses
dmoudle;
{$R *.dfm}
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn;
AList: TIdContextThreadList = nil);
begin
inherited;
OutboundCache := TIdThreadSafeStringList.Create;
Commandlist := TIdThreadSafeStringList.Create;
Commandlist.Add('Command1');
Commandlist.Add('Command2');
Commandlist.Add('Command3');
Commandlist.Add('Command4');
Commandlist.Add('Command5');
Commandlist.Add('Command6');
Commandlist.Add('Command7');
Commandlist.Add('Command8');
Commandlist.Add('Command9');
Commandlist.Add('Command10');
Commandlist.Add('Command11');
Commandlist.Add('Command12');
end;
destructor TConnection.Destroy;
var
Cache: TStringList;
Commadcaches : TStringList;
I: integer;
begin
if OutboundCache <> nil then
begin
Cache := OutboundCache.Lock;
try
for I := 0 to Cache.Count - 1 do
Cache.Objects[I].Free;
finally
OutboundCache.Unlock;
end;
OutboundCache.Free;
end;
if Commandlist <> nil then
begin
Commadcaches := Commandlist.Lock;
try
for I := 0 to Commadcaches.Count - 1 do
Commadcaches.Objects[I].Free;
finally
Commandlist.Unlock;
end;
Commandlist.Free;
end;
inherited;
end;
procedure TServobj.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command: String;
Startercommand : String;
Params: array [1 .. 200] of String;
Cache, OutboundCmds: TStringList;
ParamsCount, P: integer;
I: integer;
S: String;
DECODES : String;
UConnected : Boolean;
Len: Integer;
begin
Try
UConnected := AContext.Connection.Connected;
Except
UConnected := False;
End;
If Not UConnected Then
begin
AContext.Connection.Disconnect;
exit;
end;
Len := AContext.Connection.IOHandler.InputBuffer.Size;
If Len >= 200000 then
begin
AContext.Connection.Disconnect;
exit;
end;
Connection := AContext as TConnection;
// check for pending outbound commands...
OutboundCmds := nil;
try
Cache := Connection.OutboundCache.Lock;
try
if Cache.Count > 0 then
begin
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
end;
finally
Connection.OutboundCache.Unlock;
end;
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
AContext.Connection.IOHandler.Writeln(OutboundCmds.Strings[I],
IndyTextEncoding_UTF8);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8;
AContext.Connection.IOHandler.LargeStream := true;
AContext.Connection.IOHandler.Write(MS, 0, true);
end;
end;
Connection.LastSendRecv := Ticks64;
end;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
OutboundCmds.Objects[I].Free;
end;
end;
OutboundCmds.Free;
end;
// check for a pending inbound command...
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
AContext.Connection.IOHandler.CheckForDataOnSource(100);
AContext.Connection.IOHandler.CheckForDisconnect;
if AContext.Connection.IOHandler.InputBufferIsEmpty then
begin
if GetElapsedTicks(Connection.LastSendRecv) >= 60000 then
AContext.Connection.Disconnect;
Exit;
end;
end;
Startercommand := Decode64(AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8), IndyTextEncoding_UTF8);
Command := Startercommand;
{HERE I START TO CHECK COMMAND LIST}
if (command <> 'ISACTIVE') then
begin
if Connection.Verfieycmds(Command) <> true then
begin
AContext.Connection.Disconnect;
Exit;
end;
end;
{HERE I START TO CHECK COMMAND LIST}
Connection.LastSendRecv := Ticks64;
if Command = '' then
begin
AContext.Connection.Disconnect;
Exit;
end;
ReceiveParams := False;
ReceiveStream := False;
if Command[1] = '1' then // command with params
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := true;
end
else if Command[1] = '2' then // command + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveStream := true;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Command := Copy(Command, 2, MaxInt);
ReceiveParams := true;
ReceiveStream := true;
end;
if ReceiveParams then // params is incomming
begin
S := AContext.Connection.Socket.ReadLn(IndyTextEncoding_UTF8);
DECODES := Decode64(S, IndyTextEncoding_UTF8);
ParamsCount := 0;
while (DECODES <> '') and (ParamsCount < 200) do
begin
Inc(ParamsCount);
P := Pos(Sep, DECODES);
if P = 0 then
Params[ParamsCount] := DECODES
else
begin
Params[ParamsCount] := Copy(DECODES, 1, P - 1);
Delete(DECODES, 1, P + 5);
end;
end;
end;
if Command = 'Broadcastanymessage' then
begin
if ParamsCount <> 3 then
begin
AContext.Connection.Disconnect;
Exit;
end;
//do something
end;
end;
if i remove the Verfieycmds from the execute check the server running normally . what i am doing wrong ?
There is no reason to use a TIdThreadSafeStringList for the commands list. Only the thread that creates the list will ever be accessing it, so using a lock for it is unnecessary overhead.
And there is no reason to allocate a new list for each client, for that matter. That is just wasting memory.
Your commands are encoded in a manner that requires decoding before you can then validate them.
Try something more like this instead:
type
TConnection = class(TIdServerContext)
private
function HasInboundData: Boolean;
procedure SendOutboundCache;
public
OutboundCache: TIdThreadSafeStringList;
LastSendRecv: TIdTicks;
// ...
constructor Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil); override;
destructor Destroy; override;
end;
type
TServobj = class(TForm)
TcpServer: TIdTCPServer;
//...
procedure TcpServerConnect(AContext: TIdContext);
//...
procedure TcpServerExecute(AContext: TIdContext);
procedure FormCreate(Sender: TObject);
//...
private
//...
end;
var
Servobj: TServobj;
implementation
uses
dmoudle;
{$R *.dfm}
constructor TConnection.Create(AConnection: TIdTCPConnection; AYarn: TIdYarn; AList: TIdContextThreadList = nil);
begin
inherited;
OutboundCache := TIdThreadSafeStringList.Create;
LastSendRecv := Ticks64;
end;
destructor TConnection.Destroy;
var
Cache: TStringList;
I: integer;
begin
if OutboundCache <> nil then
begin
Cache := OutboundCache.Lock;
try
for I := 0 to Cache.Count - 1 do
Cache.Objects[I].Free;
finally
OutboundCache.Unlock;
end;
OutboundCache.Free;
end;
inherited;
end;
function TConnection.HasInboundData: Boolean;
begin
if Connection.IOHandler.InputBufferIsEmpty then
begin
Connection.IOHandler.CheckForDataOnSource(100);
Connection.IOHandler.CheckForDisconnect;
if Connection.IOHandler.InputBufferIsEmpty then
begin
if GetElapsedTicks(LastSendRecv) >= 60000 then
Connection.Disconnect;
Result := False;
Exit;
end;
end;
Result := True;
end;
procedure TConnection.SendOutboundCache;
var
Cache, OutboundCmds: TStringList;
MS: TMemoryStream;
I: integer;
begin
OutboundCmds := nil;
try
Cache := OutboundCache.Lock;
try
if Cache.Count = 0 then
Exit;
OutboundCmds := TStringList.Create;
OutboundCmds.Assign(Cache);
Cache.Clear;
finally
OutboundCache.Unlock;
end;
for I := 0 to OutboundCmds.Count - 1 do
begin
Connection.IOHandler.WriteLn(OutboundCmds.Strings[I]);
MS := TMemoryStream(OutboundCmds.Objects[I]);
if MS <> nil then
begin
Connection.IOHandler.LargeStream := true;
Connection.IOHandler.Write(MS, 0, true);
end;
end;
LastSendRecv := Ticks64;
finally
if OutboundCmds <> nil then
begin
for I := 0 to OutboundCmds.Count - 1 do
begin
OutboundCmds.Objects[I].Free;
end;
end;
OutboundCmds.Free;
end;
end;
procedure TServobj.FormCreate(Sender: TObject);
begin
TcpServer.ContextClass := TConnection;
end;
procedure TServobj.TcpServerConnect(AContext: TIdContext);
begin
AContext.Connection.IOHandler.DefStringEncoding := IndyTextEncoding_UTF8
end;
const
ValidCmds: array[0..13] of String = (
'ISACTIVE',
'Broadcastanymessage',
'Command1',
'Command2',
'Command3',
'Command4',
'Command5',
'Command6',
'Command7',
'Command8',
'Command9',
'Command10',
'Command11',
'Command12'
);
procedure TServobj.TcpServerExecute(AContext: TIdContext);
var
Connection: TConnection;
Command, Decoded: String;
Params: array[1..200] of String;
ParamsCount, P, I, WhichCmd: integer;
begin
Connection := AContext as TConnection;
// check for pending outbound commands...
Connection.SendOutboundCache;
// check for a pending inbound command...
if not Connection.HasInboundData then
Exit;
Command := Decode64(AContext.Connection.IOHandler.ReadLn, IndyTextEncoding_UTF8);
ReceiveParams := False;
ReceiveStream := False;
if Command <> '' then
begin
if Command[1] = '1' then // command with params
begin
Delete(Command, 1, 1);
ReceiveParams := true;
end
else if Command[1] = '2' then // command + memorystream
begin
Delete(Command, 1, 1);
ReceiveStream := true;
end
else if Command[1] = '3' then // command with params + memorystream
begin
Delete(Command, 1, 1);
ReceiveParams := true;
ReceiveStream := true;
end;
end;
WhichCmd := PosInStrArray(Command, ValidCmds);
if WhichCmd = -1 then
begin
AContext.Connection.Disconnect;
Exit;
end;
if ReceiveParams then // params is incomming
begin
Decoded := Decode64(AContext.Connection.IOHandler.ReadLn, IndyTextEncoding_UTF8);
ParamsCount := 0;
while (Decoded <> '') and (ParamsCount < 200) do
begin
Inc(ParamsCount);
P := Pos(Sep, Decoded);
if P = 0 then
Params[ParamsCount] := Decoded
else
begin
Params[ParamsCount] := Copy(Decoded, 1, P - 1);
Delete(Decoded, 1, P + Length(Sep));
end;
end;
end;
Connection.LastSendRecv := Ticks64;
case WhichCmd of
// process commands as needed...
1: begin // Broadcastanymessage
if ParamsCount <> 3 then
begin
AContext.Connection.Disconnect;
Exit;
end;
//do something
end;
// ...
end;
end;
I'm trying to make a combobox that selects first item back after change. My OS is Ubuntu 12.04. My code:
unit Unit1;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs, StdCtrls,
Buttons, Menus;
type
{ TForm1 }
TForm1 = class(TForm)
ComboBox1: TComboBox;
Edit1: TEdit;
Label1: TLabel;
Memo1: TMemo;
procedure ComboBox1Change(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.lfm}
{ TForm1 }
procedure TForm1.ComboBox1Change(Sender: TObject);
var Text2:String;
begin
if (Combobox1.ItemIndex = 1) Then
begin
Text2 := Memo1.SelText;
Edit1.Text := Memo1.SelText;
Memo1.SelText := '[artist]' + Text2 + '[/artist]';
end;
if (Combobox1.ItemIndex = 2) Then
begin
if (Edit1.Text = '') Then
ShowMessage('Artist name is not defined') Else
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[album artist=' + Edit1.Text + ']' + Text2 + '[/album]';
end;
end;
if (ComboBox1.ItemIndex = 3) Then
begin
if (Edit1.Text = '') Then
ShowMessage('Artist name is not defined') Else
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[track artist=' + Edit1.Text + ']' + Text2 + '[/track]'
end;
end;
if (ComboBox1.ItemIndex = 4) Then
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[label]' + Text2 + '[/label]';
end;
if (ComboBox1.ItemIndex = 5) Then
begin
Text2 := Memo1.SelText;
Memo1.SelText := '[tag]' + Text2 + '[/tag]';
end;
Combobox1.SelectFirst;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
Memo1.Text := 'Select an item';
end;
end.
This gives an error: unit1.pas(74,13) Error: identifier idents no member "SelectFirst"
How can I fix this?
the combobox haven't this procedure
if you want the first item select it by this way
ComboBox1.ItemIndex := 0
Do you know of any free components/libraries, which allow to achieve a 3D flip effect?
Demo here: snorkl.tv
Here's an attempt using SetWorldTransform:
type
TForm1 = class(TForm)
PaintBox1: TPaintBox;
Button1: TButton;
Timer1: TTimer;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
FFrontBmp, FBackBmp: TBitmap;
FBmps: array [Boolean] of TBitmap;
FXForm: TXForm;
FStep: Integer;
end;
var
Form1: TForm1;
implementation
uses
Math;
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FFrontBmp := TBitmap.Create;
FFrontBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + '53.bmp');
FBackBmp := TBitmap.Create;
FBackBmp.LoadFromFile(ExtractFilePath(Application.ExeName) + 'b1fv.bmp');
FBmps[True] := FFrontBmp;
FBmps[False] := FBackBmp;
FXForm.eM11 := 1;
FXForm.eM12 := 0;
FXForm.eM21 := 0;
FXForm.eM22 := 1;
FXForm.eDx := 0;
FXForm.eDy := 0;
Timer1.Enabled := False;
Timer1.Interval := 30;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FFrontBmp.Free;
FBackBmp.Free;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
SetGraphicsMode(PaintBox1.Canvas.Handle, GM_ADVANCED);
SetWorldTransform(PaintBox1.Canvas.Handle, FXForm);
PaintBox1.Canvas.Draw(0, 0, FBmps[FStep < 20]);
end;
procedure TForm1.Timer1Timer(Sender: TObject);
var
Bmp: TBitmap;
Sign: Integer;
begin
Inc(FStep);
Sign := math.Sign(FStep - 20);
FXForm.eM11 := FXForm.eM11 + 0.05 * Sign;
FXForm.eM21 := FXForm.eM21 - 0.005 * Sign;
FXForm.eDx := FXForm.eDx - 1 * Sign;
if FStep = 39 then begin
Timer1.Enabled := False;
PaintBox1.Refresh;
end else
PaintBox1.Invalidate;
if not Timer1.Enabled then begin
Bmp := FBmps[True];
FBmps[True] := FBmps[False];
FBmps[False] := Bmp;
end;
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
Timer1.Enabled := True;
FStep := 0;
end;
I'm not sure if this stood a chance of turning out to be anything beautiful in case I had some maths capability, but here's currently how it looks:
The images used:
Something like this might do the similar effect (just another attempt to show how this could be done, also not so precise, but it's just for fun since you've asked for a library or component). The principle is based on a rectnagle that is being resized and centered in the paint box where the card is being rendered with the StretchDraw function:
Unit1.pas
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, ExtCtrls, PNGImage;
type
TCardSide = (csBack, csFront);
TForm1 = class(TForm)
Timer1: TTimer;
Timer2: TTimer;
PaintBox1: TPaintBox;
procedure FormCreate(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure Timer1Timer(Sender: TObject);
procedure Timer2Timer(Sender: TObject);
procedure PaintBox1Click(Sender: TObject);
procedure PaintBox1Paint(Sender: TObject);
private
FCardRect: TRect;
FCardSide: TCardSide;
FCardBack: TPNGImage;
FCardFront: TPNGImage;
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
procedure TForm1.FormCreate(Sender: TObject);
begin
FCardSide := csBack;
FCardRect := PaintBox1.ClientRect;
FCardBack := TPNGImage.Create;
FCardBack.LoadFromFile('tps2N.png');
FCardFront := TPNGImage.Create;
FCardFront.LoadFromFile('Ey3cv.png');
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
FCardBack.Free;
FCardFront.Free;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
if FCardRect.Right - FCardRect.Left > 0 then
begin
FCardRect.Left := FCardRect.Left + 3;
FCardRect.Right := FCardRect.Right - 3;
PaintBox1.Invalidate;
end
else
begin
Timer1.Enabled := False;
case FCardSide of
csBack: FCardSide := csFront;
csFront: FCardSide := csBack;
end;
Timer2.Enabled := True;
end;
end;
procedure TForm1.Timer2Timer(Sender: TObject);
begin
if FCardRect.Right - FCardRect.Left < PaintBox1.ClientWidth then
begin
FCardRect.Left := FCardRect.Left - 3;
FCardRect.Right := FCardRect.Right + 3;
PaintBox1.Invalidate;
end
else
Timer2.Enabled := False;
end;
procedure TForm1.PaintBox1Click(Sender: TObject);
begin
Timer1.Enabled := False;
Timer2.Enabled := False;
FCardRect := PaintBox1.ClientRect;
Timer1.Enabled := True;
PaintBox1.Invalidate;
end;
procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
case FCardSide of
csBack: PaintBox1.Canvas.StretchDraw(FCardRect, FCardBack);
csFront: PaintBox1.Canvas.StretchDraw(FCardRect, FCardFront);
end;
end;
end.
Unit1.dfm
object Form1: TForm1
Left = 0
Top = 0
Caption = 'Form1'
ClientHeight = 203
ClientWidth = 173
Color = clBtnFace
DoubleBuffered = True
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'Tahoma'
Font.Style = []
OldCreateOrder = False
Position = poScreenCenter
OnCreate = FormCreate
OnDestroy = FormDestroy
PixelsPerInch = 96
TextHeight = 13
object PaintBox1: TPaintBox
Left = 48
Top = 40
Width = 77
Height = 121
OnClick = PaintBox1Click
OnPaint = PaintBox1Paint
end
object Timer1: TTimer
Enabled = False
Interval = 10
OnTimer = Timer1Timer
Left = 32
Top = 88
end
object Timer2: TTimer
Enabled = False
Interval = 10
OnTimer = Timer2Timer
Left = 88
Top = 88
end
end
Cards