How do I load a chess board into program once saved? - delphi

I have a procedure that saves a chess board into a text file. I am trying to read the board back in to the program once saved. When I call this procedure I get this error.
Code which I have for loading in board.
Procedure LoadBoard(Var Board : Tboard);
var
fptr:text;
i,j,x:integer;
line:string;
load:char;
begin
Write('Do you want a load a game? (Enter Y for yes)');
Readln(load);
If (Ord(load) >= 97) and (Ord(load) <= 122)
Then load := Chr(Ord(load) - 32);
if load='Y' then
begin
assignfile(fptr,'SBoard.txt');
reset(fptr);
i:=1;
repeat
readln(fptr,line);
j:=1;
x:=1;
repeat
begin
if (line[x]<>',') and (line[x+1]<>',')
then
begin
Board[i,j][1]:=line[x];
Board[i,j][2]:=line[x+1];
end;
if line[x]=','
then
j:=j+1;
x:=x+1;
end;
until j=9;
i:=i+1;
until i=9;
close(fptr);
end;
end;

You get the Access Violation exception because the string members in your Board array are empty (length is zero) and therefore have no accessible character positions.
To fix your present code, you should use SetLength() on each string member before you assign content to the character positions. You have not shown what the strings contain, so only you know what the set length should be.
On the other hand, in previous answer to your questions you have been adviced several other methods to save your chess board. You should review those and possibly choose one of them. It would also be polite to respond to those answers and maybe tell why you did not select them. Maybe we were not able to explain the benefits.

You are over complicating things by using a Text file and saving your board line by line.
I think you should use a TStringList for saving and loading :
Const
BoardDimension = 8;
BoardFileName = 'SBoard.txt';
Type
TBoard = Array [1 .. BoardDimension, 1 .. BoardDimension] Of String;
procedure SaveBoard(Board: TBoard);
var
i, j: Integer;
Line, BoardFile: TStringList;
begin
BoardFile := TStringList.Create;
Line := TStringList.Create;
for i := 1 to BoardDimension do
begin
Line.Clear;
for j := 1 to BoardDimension do
Line.Add(Board[i, j]);
BoardFile.Add(Line.CommaText);
end;
Line.Free;
BoardFile.SaveToFile(BoardFileName);
BoardFile.Free;
end;
procedure LoadBoard(Board: TBoard);
var
i, j: Integer;
Line, BoardFile: TStringList;
begin
if not FileExists(BoardFileName) then
exit; // Show error message
BoardFile := TStringList.Create;
BoardFile.LoadFromFile(BoardFileName);
Line := TStringList.Create;
for i := 1 to BoardDimension do
begin
Line.CommaText := BoardFile[i];
for j := 1 to BoardDimension do
Board[i, j] := Line[j];
end;
Line.Free;
BoardFile.Free;
end;
And if you want to test the load an save proceudre you could do it like this :
procedure Test;
var
Board: TBoard;
BoardA: TBoard;
i, j: Integer;
begin
randomize;
for i := 1 to BoardDimension do
for j := 1 to BoardDimension do
Board[i, j] := Random(500).ToString;
SaveBoard(Board); //Save Board
LoadBoard(BoardA); //Load the file into a NEW board
for i := 1 to BoardDimension do //Comapre the two boards
for j := 1 to BoardDimension do
if Board[i,j] <> BoardA[i,j] then
raise Exception.Create('Wrong file format');
end;

Related

Search numbers in different Memos and separate them into one

I'm having trouble searching for strings in different memos and separating them.
Let's go to the scene.
in Memo1 i have the following text
18049,25047,text4
18047,25046,text2
18048,25045,text3
18050,25048,text5
18046,25044,text1
and in Memo2
25049,9012646205,55315135004,adou4
25047,"",06252782912,textasidh
25046,"",44425660030,textblabla
25048,"",07649186806,textaldj
I need to separate the first digits up to the comma of memo2 and fetch into memo1 and add the complete lines. Memo1 + Memo2 in Memo3.
18046,25044,text1 25046,"",44425660030,textblabla
18047,25046,text2 25047,"",06252782912,textasidh
18048,25045,text3 25048,"",07649186806,textaldj
18049,25047,text4 25049,9012646205,55315135004,adou4
I've already tried using the function Split(Text, Delimitador: string): TSarray; but without success
var
I, J: Byte;
Z : String;
begin
for I := 1 to 2 do
begin
for J := 0 to TMemo(FindComponent('Memo'+IntToStr(I))).Lines.Count -1 do
begin
Z := Memo2.Lines[J];
if Pos(Split(Z, ',')[0],TMemo(FindComponent('Memo'+IntToStr(I))).Lines[J]) > 0 then
Memo3.Lines.Add(TMemo(FindComponent('Memo'+IntToStr(I))).Lines[J]);
end;
end;
end;
solved
var
I, J : byte;
begin
for I := 0 to Memo1.Lines.Count -1 do
begin
for J := 0 to Memo2.Lines.Count -1 do
begin
if Pos(Split(Memo2.Lines[J], ',')[0],Memo1.Lines[I]) > 0 then
Memo3.Lines.Add(Memo1.Lines[I]+' # '+Memo2.Lines[J]);
end;
end;
end;

Procedure fires without being called

Is it possible, in delphi, that a procedure fires without being called?
I have two completly different procedure. First one is a click on popup menu. The second one is a function which i defined to split a string.
And i don't call my split method in my click of popup menu but it fires anyway and i can't find why. Debugger just says he can't read adress 00000001 but i don't even want him to read cause i don't call this procedure in any of my popup options. Does anyone have any idea of why it could fire by its own?
I can edit code if you want but idk it will be usefull as both procedure arent linked x)
CODE
procedure TBDDTool.pmDeleteColumnClick(Sender: TObject);
var
i: integer;
sListColNames : string;
begin
fileModified := true;
sListColNames := '';
//Increment undo number
Inc(undoNum);
if undoNum = 11 then
begin
for i := 0 to Length(UndoArray) - 1 do
begin
if i < Length(UndoArray)-1 then
UndoArray[i] := UndoArray[i+1];
end;
undoNum := UndoNum -1;
end;
//Add action to the array of undo actions
undoArray[undoNum] := 'Deleted column:' + IntToStr(sgFilePreview.Col)
+'$'+aSourceData[0,sgFilePreview.Col] + '#deleted';
pmUndo.Enabled := true;
if (Pos('#primarykeypk', aSourceData[0, sgFilePreview.Col]) <> 0) then
begin
aSourceData[0,sgFilePreview.Col] := COPY(aSourceData[0,sgFilePreview.Col], 0, Pos('#primarykey', aSourceData[0, sgFilePreview.Col])-1);
pmPrimaryKey.Enabled := true;
end;
if (Pos('#', aSourceData[0, sgFilePreview.Col]) <> 0) then
aSourceData[0,sgFilePreview.Col] := COPY(aSourceData[0,sgFilePreview.Col], 0, Pos('#', aSourceData[0, sgFilePreview.Col])-1);
for i := 0 to Length(aSourceData[0])-1 do
begin
if aSourceData[0,i] = sgFilePreview.Cells[sgFilePreview.Col, 0] then
begin
aSourceData[0,i] := aSourceData[0,i] + '#deleted';
Break;
end;
end;
//just set col width to 0 to hide it but we need the index
sgFilePreview.ColWidths[sgFilePreview.Col] := 0;
end;
//Custom split method
function TBDDTool.Explode(const Separator, s: String;
Limit: Integer): TStringDynArray;
var
SepLen: Integer;
F, P: PChar;
ALen, Index: Integer;
begin
SetLength(Result,0);
//if the word passed is empty there's no need to continue
if (S = '') or (Limit < 0) then Exit;
if Separator = '' then
begin
SetLength(Result, 1);
Result[0] := S;
Exit;
end;
//Set to the length of the separator
SepLen := Length(Separator);
ALen := Limit;
SetLength(Result, ALen);
Index := 0;
P := PChar(s);
While P^ <> #0 do
begin
F := P;
P := AnsiStrPos(P,PChar(Separator));
if (P = nil) OR ((Limit > 0) AND (Index = Limit -1)) then P := StrEnd(F);
if Index >= ALen then
begin
Inc(ALen,5);
SetLength(Result, ALen);
end;
SetString(Result[Index], F, P-F);
INC(Index);
if p^ <> #0 then Inc(P,SepLen);
end;
if index < ALen then SetLength(Result, Index);
end;
The explode functions is called when i click delet option (from a popup menu). But i don't call the explode function in my delete procedure. The break happens on while P^ <> #0 line
Is it possible, in delphi, that a procedure fires without being called?
Generally speak, it is not possible. If code executes, something in the system made it execute.
However, it is possible that you have somehow corrupted memory. That in turn may lead to you calling one function and the corruption leading to a different function being called.
In order to debug this I suggest that you first of all inspect the call stack when the unexpected function begins executing. That should tell you how the execution reached that point. If that's not enough to explain things, cut your code down to the bare minimum that produces the problem. It's harder to find problems when there's lots of code. By cutting down to a minimum, you'll make it easier to see what has gone wrong.

Faster way to split text in Delphi TStringList

I have an app that needs to do heavy text manipulation in a TStringList. Basically i need to split text by a delimiter ; for instance, if i have a singe line with 1000 chars and this delimiter occurs 3 times in this line, then i need to split it in 3 lines. The delimiter can contain more than one char, it can be a tag like '[test]' for example.
I've wrote two functions to do this task with 2 different approaches, but both are slow in big amounts of text (more then 2mbytes usually).
How can i achieve this goal in a faster way ?
Here are both functions, both receive 2 paramaters : 'lines' which is the original tstringlist and 'q' which is the delimiter.
function splitlines(lines : tstringlist; q: string) : integer;
var
s, aux, ant : string;
i,j : integer;
flag : boolean;
m2 : tstringlist;
begin
try
m2 := tstringlist.create;
m2.BeginUpdate;
result := 0;
for i := 0 to lines.count-1 do
begin
s := lines[i];
for j := 1 to length(s) do
begin
flag := lowercase(copy(s,j,length(q))) = lowercase(q);
if flag then
begin
inc(result);
m2.add(aux);
aux := s[j];
end
else
aux := aux + s[j];
end;
m2.add(aux);
aux := '';
end;
m2.EndUpdate;
lines.text := m2.text;
finally
m2.free;
end;
end;
function splitLines2(lines : tstringlist; q: string) : integer;
var
aux, p : string;
i : integer;
flag : boolean;
begin
//maux1 and maux2 are already instanced in the parent class
try
maux2.text := lines.text;
p := '';
i := 0;
flag := false;
maux1.BeginUpdate;
maux2.BeginUpdate;
while (pos(lowercase(q),lowercase(maux2.text)) > 0) and (i < 5000) do
begin
flag := true;
aux := p+copy(maux2.text,1,pos(lowercase(q),lowercase(maux2.text))-1);
maux1.add(aux);
maux2.text := copy(maux2.text,pos(lowercase(q),lowercase(maux2.text)),length(maux2.text));
p := copy(maux2.text,1,1);
maux2.text := copy(maux2.text,2,length(maux2.text));
inc(i);
end;
finally
result := i;
maux1.EndUpdate;
maux2.EndUpdate;
if flag then
begin
maux1.add(p+maux2.text);
lines.text := maux1.text;
end;
end;
end;
I've not tested the speed, but for academic purposes, here's an easy way to split the strings:
myStringList.Text :=
StringReplace(myStringList.Text, myDelimiter, #13#10, [rfReplaceAll]);
// Use [rfReplaceAll, rfIgnoreCase] if you want to ignore case
When you set the Text property of TStringList, it parses on new lines and splits there, so converting to a string, replacing the delimiter with new lines, then assigning it back to the Text property works.
The problems with your code (at least second approach) are
You are constantly using lowecase which is slow if called so many times
If I saw correctly you are copying the whole remaining text back to the original source. This is sure to be extra slow for large strings (eg files)
I have a tokenizer in my library. Its not the fastest or best but it should do (you can get it from Cromis Library, just use the units Cromis.StringUtils and Cromis.Unicode):
type
TTokens = array of ustring;
TTextTokenizer = class
private
FTokens: TTokens;
FDelimiters: array of ustring;
public
constructor Create;
procedure Tokenize(const Text: ustring);
procedure AddDelimiters(const Delimiters: array of ustring);
property Tokens: TTokens read FTokens;
end;
{ TTextTokenizer }
procedure TTextTokenizer.AddDelimiters(const Delimiters: array of ustring);
var
I: Integer;
begin
if Length(Delimiters) > 0 then
begin
SetLength(FDelimiters, Length(Delimiters));
for I := 0 to Length(Delimiters) - 1 do
FDelimiters[I] := Delimiters[I];
end;
end;
constructor TTextTokenizer.Create;
begin
SetLength(FTokens, 0);
SetLength(FDelimiters, 0);
end;
procedure TTextTokenizer.Tokenize(const Text: ustring);
var
I, K: Integer;
Counter: Integer;
NewToken: ustring;
Position: Integer;
CurrToken: ustring;
begin
SetLength(FTokens, 100);
CurrToken := '';
Counter := 0;
for I := 1 to Length(Text) do
begin
CurrToken := CurrToken + Text[I];
for K := 0 to Length(FDelimiters) - 1 do
begin
Position := Pos(FDelimiters[K], CurrToken);
if Position > 0 then
begin
NewToken := Copy(CurrToken, 1, Position - 1);
if NewToken <> '' then
begin
if Counter > Length(FTokens) then
SetLength(FTokens, Length(FTokens) * 2);
FTokens[Counter] := Trim(NewToken);
Inc(Counter)
end;
CurrToken := '';
end;
end;
end;
if CurrToken <> '' then
begin
if Counter > Length(FTokens) then
SetLength(FTokens, Length(FTokens) * 2);
FTokens[Counter] := Trim(CurrToken);
Inc(Counter)
end;
SetLength(FTokens, Counter);
end;
How about just using StrTokens from the JCL library
procedure StrTokens(const S: string; const List: TStrings);
It's open source
http://sourceforge.net/projects/jcl/
As an additional option, you can use regular expressions. Recent versions of Delphi (XE4 and XE5) come with built in regular expression support; older versions can find a free regex library download (zip file) at Regular-Expressions.info.
For the built-in regex support (uses the generic TArray<string>):
var
RegexObj: TRegEx;
SplitArray: TArray<string>;
begin
SplitArray := nil;
try
RegexObj := TRegEx.Create('\[test\]'); // Your sample expression. Replace with q
SplitArray := RegexObj.Split(Lines, 0);
except
on E: ERegularExpressionError do begin
// Syntax error in the regular expression
end;
end;
// Use SplitArray
end;
For using TPerlRegEx in earlier Delphi versions:
var
Regex: TPerlRegEx;
m2: TStringList;
begin
m2 := TStringList.Create;
try
Regex := TPerlRegEx.Create;
try
Regex.RegEx := '\[test\]'; // Using your sample expression - replace with q
Regex.Options := [];
Regex.State := [preNotEmpty];
Regex.Subject := Lines.Text;
Regex.SplitCapture(m2, 0);
finally
Regex.Free;
end;
// Work with m2
finally
m2.Free;
end;
end;
(For those unaware, the \ in the sample expression used are because the [] characters are meaningful in regular expressions and need to be escaped to be used in the regular expression text. Typically, they're not required in the text.)

Word blocks in TMemo

I am trying to make a basic Hex viewer out of a TMemo, I know this is probably not ideal but it will be only me personally using it so that does not really matter.
(1)
Firstly, suppose a Memo is filled with Hex information like so:
How could I get a count of all the text blocks shown, ignoring the white space? So using the image the result in this case would be 28.
This is what I tried and I know it is completely wrong as I am accessing the Memo lines but I don't know how to access each character.
I cant seem to solve this simple problem :(
function CountWordBlocks(Memo: TMemo): Integer;
var
i: Integer;
vCount: Integer;
begin
for i := 0 to Memo.Lines.Count - 1 do
begin
if Length(Memo.Lines.Strings[i]) = 2 then
begin
Inc(vCount);
end;
end;
Result := vCount;
end;
Here is the code I am using to display the Hex values in the Memo:
procedure ReadFileAsHex(const AFileName: string; ADestination: TStrings);
var
fs: TFileStream;
buff: Byte;
linecount: Byte;
line: string;
begin
linecount := 0;
line := '';
fs := TFileStream.Create(AFileName, fmOpenRead);
try
ADestination.BeginUpdate;
try
while fs.Position < fs.Size do
begin
fs.Read(buff, 1);
line := line + IntToHex(buff, 2) + ' ';
Inc(linecount);
if linecount = 16 then
begin
ADestination.Add(line);
line := '';
linecount := 0;
end;
end;
if Length(line) <> 0 then
ADestination.Add(line);
finally
ADestination.EndUpdate;
end;
finally
fs.Free;
end;
end;
(2)
If I click onto the Memo and a text block is under the cursor, how could I know which number the selected block is out of all the others?
So using the same first image, the caret is at the top line next to 68, so the result would be 3 as it is the third text block out of 28.
This should be so easy but I cannot think clearly, I don't have the right programming mind yet and so really struggle with basic logic and solving problems!
(3)
Finally I would like to select a block at runtime by passing a block number value. I tried this without much success:
procedure FindBlock(Memo: TMemo; BlockNumber: Integer);
var
i: Integer;
txt: string;
ThisWhite, PrevWhite: boolean;
vRead: Integer;
begin
txt := Memo.Text;
vRead:= 0;
PrevWhite := True;
for i := 1 to Length(txt) do
begin
ThisWhite := Character.IsWhiteSpace(txt[i]);
if PrevWhite and not ThisWhite then
begin
Inc(vRead);
PrevWhite := False;
end;
PrevWhite := ThisWhite;
if vRead = BlockNumber then
begin
Memo.SelStart := vRead;
Memo.SetFocus;
Exit;
end;
end;
end;
(1)
This works:
function TForm1.CountBlocks: integer;
var
i: Integer;
txt: string;
ThisWhite, PrevWhite: boolean;
begin
txt := Memo1.Text;
result:= 0;
PrevWhite := true;
for i := 1 to Length(txt) do
begin
ThisWhite := Character.IsWhiteSpace(txt[i]);
if PrevWhite and not ThisWhite then
begin
inc(result);
PrevWhite := false;
end;
PrevWhite := ThisWhite;
end;
end;
However, it can be optimized if more detailed information about the memo contents is available. For instance, if you know that each line consists of four blocks, then the number of blocks is simply 4*Memo1.Lines.Count. My code above will even accept blocks of different width.
(2)
Simply replace
for i := 1 to Length(txt) do
by
for i := 1 to Memo1.SelStart + 1 do
Since you are in control of the formatting of your lines, and the lines have a fixed format, it is very easy to calculate the number of bytes being displayed without resorting to looping through the individual lines one a time. Every line displays 3 characters per byte, and every line other than the last line displays 16 bytes, thus 48 characters per complete 16-byte line. Use those facts to your advantage to calculate the number of bytes based on the number of complete 16-byte lines present, and then you can add on the number of remaining bytes from just the last line:
function CountWordBlocks(Memo: TMemo): Integer;
var
Count: Integer;
begin
Count := Memo.Lines.Count;
if Count > 0 then
Result := (16 * (Count-1)) + (Length(Memo.Lines[Count-1]) div 3);
else
Result := 0;
end;
You can do something similar to translate a character offset within the Memo into a work block number:
function GetCurrentWordBlock(Memo: TMemo): Integer;
var
SelStart, LineStart, LineNum: Integer
begin
Result := 0;
SelStart := Memo.SelStart;
if SelStart < 0 then Exit;
LineStart := Memo.Perform(EM_LINEINDEX, SelStart, 0);
if LineStart < 0 then Exit;
LineNum := Memo.Perform(EM_LINEFROMCHAR, LineStart, 0);
Result := (16 * LineNum) + ((SelStart - LineStart) div 3) + 1;
end;
To select a given block number, you can do this:
procedure FindBlock(Memo: TMemo; BlockNumber: Integer);
var
LineNum, LineStart: Integer;
begin
if BlockNumber < 1 then Exit;
LineNum = (BlockNumber - 1) div 16;
LineStart = Memo.Perform(EM_LINEINDEX, LineNum, 0);
if LineStart < 0 then Exit;
Memo.SelStart = LineStart + (((BlockNumber - 1) - (16 * LineNum)) * 3);
Memo.SelLength := 2;
Memo.SetFocus;
end;

GetFormFieldNames not always working

I am trying to find out which form and element belongs too. The code that I now understand from this website:
http://www.cryer.co.uk/brian/delphi/twebbrowser/read_write_form_elements.htm
containing this code
function GetFormFieldNames(fromForm: IHTMLFormElement): TStringList;
var
index: integer;
field: IHTMLElement;
input: IHTMLInputElement;
select: IHTMLSelectElement;
text: IHTMLTextAreaElement;
begin
result := TStringList.Create;
for index := 0 to fromForm.length do
begin
field := fromForm.Item(index,'') as IHTMLElement;
if Assigned(field) then
begin
if field.tagName = 'INPUT' then
begin
// Input field.
input := field as IHTMLInputElement;
result.Add(input.name);
end
else if field.tagName = 'SELECT' then
begin
// Select field.
select := field as IHTMLSelectElement;
result.Add(select.name);
end
else if field.tagName = 'TEXTAREA' then
begin
// TextArea field.
text := field as IHTMLTextAreaElement;
result.Add(text.name);
end;
end;
end;
end;
seems to be working fine for most sites. However there are a few websites such as this one:
http://service.mail.com/registration.html#.1258-bluestripe-product1-undef
By looking at that code and comparing it with the active id, I can find the form it is in. However it does not work for that website. for some reason I think it has to do with htmldocument3 adn that this code is for htmldocument2. But I am not sure.
so my question is How can I extract a tstringlist from this website with all the elements names in them? hope you can help!
Edited: Added some code
begin
theForm := GetFormByNumber(webbrowser1.document as IHTMLDocument2,
0);
fields := GetFormFieldNames(theForm);
num := fields.IndexOf(theid);
end;
until (num <> -1);
One complication with locating form elements in a web page is that the page may contain frames and there may be forms in any of the frames. Basically, you have to iterate through all the frames and the forms in each frame. Once you get the form as an IHTMLFormElement, use Cryer's function to get the form element names.
The example link you gave does not have any frames and you should have had no problems getting your list of form elements, unless you tried to get the form by name because it had no name assigned. I had no problem getting the form element names and values using the following procedure
procedure GetForms(doc1: IHTMLDocument2; var sl: TStringList);
var
i, j, n: integer;
docForm: IHTMLFormElement;
slt: TStringList;
s: string;
begin
if doc1 = nil then
begin
ShowMessage('doc1 is empty [GetForms]');
Exit;
end;
slt := TStringList.Create;
n := NumberOfForms(doc1);
sl.Add('Forms: ' + IntToStr(n));
for i := 0 to n - 1 do
begin
docForm := GetFormByNumber(doc1, i);
sl.Add('Form Name: ' + docForm.Name);
slt.Clear;
slt := GetFormFieldNames(docForm);
for j := 0 to slt.Count - 1 do
begin
s := GetFieldValue(docForm, slt[j]);
sl.Add('Field Name: ' + slt[j] + ' value: "' + s + '"');
end;
end;
sl.Add('');
slt.Free;
end;
Cryer's example for navigating a frameset will not work for all web sites, see http://support.microsoft.com/support/kb/articles/Q196/3/40.ASP. The following function successfuly extracts a frame as an IHTMLDocument2 on all sites I have tried
function GetFrameByNumber(Doc:IHTMLDocument2; n:integer):IHTMLDocument2;
var
Container: IOleContainer;
Enumerator: ActiveX.IEnumUnknown;
Unknown: IUnknown;
Browser: IWebBrowser2;
Fetched: Longint;
NewDoc: IHTMLDocument2;
i : integer;
begin
// We cannot use the document's frames collection here, because
// it does not work in every case (i.e. Documents from a foreign domain).
// From: http://support.microsoft.com/support/kb/articles/Q196/3/40.ASP
i := 0;
if (Supports(Doc, IOleContainer, Container)) and
(Container.EnumObjects(OLECONTF_EMBEDDINGS, Enumerator) = S_OK) then
begin
while Enumerator.Next(1, Unknown, #Fetched) = S_OK do
begin
if (Supports(Unknown, IWebBrowser2, Browser)) and
(Supports(Browser.Document, IHTMLDocument2, NewDoc)) then
begin
// Here, NewDoc is an IHTMLDocument2 that you can query for
// all the links, text edits, etc.
if i=n then
begin
Result := NewDoc;
Exit;
end;
i := i+1;
end;
end;
end;
end;
Here is an example of how I have used GetForms and GetFrameByNumber
// from the TForm1 declaration
{ Public declarations }
wdoc: IHTMLDocument2;
procedure TForm1.btnAnalyzeClick(Sender: TObject);
begin
wdoc := WebBrowser.Document as IHTMLDocument2;
GetDoc(wdoc);
end;
procedure TForm1.GetDoc(doc1: IHTMLDocument2);
var
i, n: integer;
doc2: IHTMLDocument2;
frame_dispatch: IDispatch;
frame_win: IHTMLWindow2;
ole_index: olevariant;
sl: TStringList;
begin
if doc1 = nil then
begin
ShowMessage('Web doc is empty');
Exit;
end;
Form2.Memo1.Lines.Clear;
sl := TStringList.Create;
n := doc1.frames.length;
sl.Add('Frames: ' + IntToStr(n));
// check each frame for the data
if n = 0 then
GetForms(doc1, sl)
else
for i := 0 to n - 1 do
begin
sl.Add('--Frame: ' + IntToStr(i));
ole_index := i;
frame_dispatch := doc1.Frames.Item(ole_index);
if frame_dispatch <> nil then
begin
frame_win := frame_dispatch as IHTMLWindow2;
doc2 := frame_win.document;
// sl.Add(doc2.body.outerHTML);
GetForms(doc2,sl);
GetDoc(doc2);
end;
end;
// Form2 just contains a TMemo
Form2.Memo1.Lines.AddStrings(sl);
Form2.Show;
sl.Free;
end;
The logic in your example is faulty, 1. when there is only 1 form on the web page the list of form elements is never extracted, 2. the repeat loop will result in a access violation unless the the tag in "theid" is found
Here is your example cut down to successfully extract the form elements.
var
i : integer;
nforms : integer;
document : IHTMLDocument2;
theForm : IHTMLFormElement;
fields : TStringList;
theform1 : integer;
num : integer;
theid : string;
begin
fields := TStringList.Create;
theid := 'xx';
// original code follows
i := -1;
// nforms := NumberOfForms(webbrowser1.document as IHTMLDocument2);
// document := webbrowser1.document as IHTMLDocument2;
// if nforms = 1 then
// begin
// theForm := GetFormByNumber(webbrowser1.document as IHTMLDocument2, 0);
// theform1 := 0;
// end
// else
begin
// repeat
begin
inc(i);
theForm := GetFormByNumber(webbrowser1.document as IHTMLDocument2,
i);
fields := GetFormFieldNames(theForm);
num := fields.IndexOf(theid);
theform1 := i;
end;
// until (num <> -1);
end;
// end of original code
Memo1.Lines.Text := fields.Text;
fields.Free;
end;
Hm, are you sure this link contains any form elements? At least I did not see any visible ones. Perhaps they are hidden - did not check this myself, however.
Michael

Resources