Chromium: How to get all form of a loaded page - delphi

I try to get the name of all forms of the loaded page. I have done this:
procedure TForm2.Button2Click(Sender: TObject);
var
L: TStringList;
begin
L := TStringList.Create;
try
Chromium1.Browser.MainFrame.VisitDomProc(
procedure (const doc: ICefDomDocument)
procedure IterateNodes(Node: ICefDomNode);
begin
if not Assigned(Node) then Exit;
repeat
if Node.ElementTagName = 'FORM' then
L.Add(Node.GetElementAttribute('name'));
if Node.HasChildren then IterateNodes(Node.FirstChild);
Node := Node.NextSibling;
until not Assigned(Node);
end;
begin
IterateNodes(doc.Body);
end
);
ShowMessage(L.Text);
finally
FreeAndNil(L);
end;
end;
But I don't have any result. Any idea?
Thanks

With XE2 Update 4
I have realized that the program flow continues when running the procedure parameter so that upon reaching the ShowMessage still has not run this procedure and therefore the TStringList is empty.
I have put a boolean variable control and it worked right, but this is not a elegant solution.
Here the new code:
procedure TForm2.Button2Click(Sender: TObject);
var
L: TStringList;
Finish: Boolean;
begin
L := TStringList.Create;
Finish := False;
try
Chromium1.Browser.MainFrame.VisitDomProc(
procedure (const doc: ICefDomDocument)
procedure IterateNodes(Node: ICefDomNode);
begin
if not Assigned(Node) then Exit;
repeat
if SameText(Node.ElementTagName, 'FORM') then
begin
L.Add(Node.GetElementAttribute('name'));
end;
if Node.HasChildren then
IterateNodes(Node.FirstChild);
Node := Node.NextSibling;
until not Assigned(Node);
end;
begin
IterateNodes(doc.Body);
Finish := True;
end
);
repeat Application.ProcessMessages until (Finish);
ShowMessage(L.Text);
finally
FreeAndNil(L);
end;
end;

I managed to get the whole page like this:
Inject a DOM element - text.
ChromiumWB.Browser.MainFrame.ExecuteJavaScript('$("body").prepend(''<input type="text" id="msoftval" value=""/>'')', '', 0);
Use jquery or js to get body html into injected element.
mResult := '';
ChromiumWB.Browser.MainFrame.ExecuteJavaScript('$("#msoftval").val($("body").html());', '', 0);
ChromiumWB.Browser.MainFrame.VisitDomProc(getResult);
while mResult = '' do Application.ProcessMessages;
Memo1.Text := mResult;
wait untill 'VisitDomProc' finish- make it sync.
procedure TForm44.getResult(const doc: ICefDomDocument);
var
q: ICefDomNode;
begin
q := doc.GetElementById('msoftval');
if Assigned(q) then
mResult := q.GetValue
else
mResult := '-';
end;

Related

Retrieve Word server properties with Delphi

Thanks to the below functions, I am succesfully retrieving, from a Word document stored locally (synced with the Server through OneDrive), its Server properties (those which are stored as SharePoint columns), all this without Ole automation. The functions' structure is:
Since the Word document is a zipped file, unzip the file where such properties are stored.
Extract the contents of the file into a string.
Load the string into an XML document.
Feed the field names and their contents into a StringList.
``
function WordGetServerProperties (FName:string):TStringList;
var
s,ss:string;
i,ii:integer;
St:TStringList;
XML:IXMLDocument;
N,NN: IXMLNode;
begin
s:=ExtractZipToStr(FName,'customXml/item1.xml',ExtractFilePath(FName));
if StrContains('<p:properties',s)=False then
s:=ExtractZipToStr(FName,'customXml/item2.xml',ExtractFilePath(FName));
if StrContains('<p:properties',s)=False then
s:=ExtractZipToStr(FName,'customXml/item3.xml',ExtractFilePath(FName));
XML:=NewXMLDocument;
St:=TStringList.Create;
XML.Active := True;
XML.LoadFromXML(s);
N:=xml.DocumentElement;
try
for i := 0 to N.ChildNodes.Count -1 do
begin
if N.ChildNodes[i].NodeName = 'documentManagement' then
begin
NN:=N.ChildNodes[i];
for ii := 0 to NN.ChildNodes.Count -1 do
begin
ss:=AnsiReplaceStr(NN.ChildNodes[ii].NodeName,'_x0020_',' ');
if ss='SharedWithUsers' then continue;
ss:=ss+'='+NN.ChildNodes[ii].Text;
st.Add(ss)
end;
end;
end;
finally
XML.Active := False;
end;
Result:=st;
end;
function ExtractZipToStr(const ZipFileName: string; const ZippedFileName, ExtractedFileName: string): widestring;
var
ZipFile: TZipFile;
F,s:string;
i:integer;
Exists:Boolean;
LStream: TStream;
FStream:TFileStream;
LocalHeader: TZipHeader;
begin
Exists:=False;
ZipFile := TZipFile.Create;
LStream := TStream.Create;
try
try
ZipFile.Open(ZipFileName,zmRead);
except on EZipException do begin Result:='noprops'; ZipFile.Close; ZipFile.Free; LStream.Free; exit; end; end;
for i := 0 to ZipFile.FileCount - 1 do
begin
F:= ZipFile.FileNames[i];
if F='docProps/custom.xml' then begin Exists:=True; system.Break; end;
end;
if exists=True then
begin
ZipFile.Read(ZippedFileName, LStream, LocalHeader);
LStream.Position:=0;
Result:=StreamToString(LStream);
end
else Result:='noprops';
finally
ZipFile.Close;
ZipFile.Free;
LStream.Free;
end;
end;
function StreamToString(aStream: TStream): widestring;
var
SS: TStringStream;
begin
if aStream <> nil then
begin
SS := TStringStream.Create('');
try
SS.CopyFrom(aStream, 0);
Result := SS.DataString;
finally
SS.Free;
end;
end else
begin
Result := '';
end;
end;
This is relatively fast but as not as much as I would like. Hopefully I have shown that (being amateur at this) I am at the end of my wits. Would you see any way to either improve or utterly replace these routines by something more efficient?

MDI Application, check if a child form with the same caption is open

I have a Delphi MDI application that has a customer search child form which can only be opened once (checking isAssigned), however the view / edit form can be opened multiple times so that the end user can open multiple customers at once (Tabbed), what I'd like to do is be able to stop them from opening the same customer record more than once, on the open of the customer form I set the caption to the customers account reference and if that form exists I would like to .BringToFront, if not I'll create it.
What would be the best way to achieve this please, as I'm scratching my head!
Thanks in advance.
procedure TfrmCustomerSearch.ViewCustomerExecute(Sender: TObject);
begin
screen.cursor := crappstart;
if not IsMDIChildOpen(frmMainMenu, 'frmCustomerView', pfrmCaption) then
frmCustomerView := TfrmCustomerView.createform(nil,dmCustomerSearchfrm.FDQCustSearchreference.Value,cxGrid1DBTableView1.DataController.FocusedRecordIndex)
else
frmCustomerView.BringToFront;
screen.cursor := crdefault;
end;
function TfrmCustomerSearch.IsMDIChildOpen(const AFormName: TForm; const AMDIChildName, AMDICaption : string): Boolean;
var
i: Integer;
begin
Result := False;
for i := Pred(AFormName.MDIChildCount) DownTo 0 do
if (AFormName.MDIChildren[i].name = AMDIChildName) then
begin
if (AFormName.MDIChildren[i].caption = AMDICaption) then
begin
Result := True;
Break;
end
end;
end;
Try something more like this instead:
procedure TfrmCustomerSearch.ViewCustomerExecute(Sender: TObject);
begin
Screen.Cursor := crAppStart;
try
frmCustomerView := TfrmCustomerView(FindMDIChildOpen(frmMainMenu, TfrmCustomerView, pfrmCaption));
if frmCustomerView = nil then
frmCustomerView := TfrmCustomerView.CreateForm(nil, dmCustomerSearchfrm.FDQCustSearchreference.Value, cxGrid1DBTableView1.DataController.FocusedRecordIndex);
frmCustomerView.BringToFront;
finally
Screen.Cursor := crDefault;
end;
end;
function TfrmCustomerSearch.FindMDIChildOpen(const AParentForm: TForm; const AMDIChildClass: TFormClass; const AMDICaption : string): TForm;
var
i: Integer;
Child: TForm;
begin
Result := nil;
for i := Pred(AParentForm.MDIChildCount) DownTo 0 do
begin
Child := AParentForm.MDIChildren[i];
if Child.InheritsFrom(AMDIChildClass) and
(Child.Caption = AMDICaption) then
begin
Result := Child;
Exit;
end;
end;
end;

Delphi Inconsistent data coming from a hardware using Cport

I am having trouble getting the serial port data from an equipment.
Below is the image of the expected result:
Desire result:
Unwanted result:
I use Ttimer so I can automatically get the data and put it to the Memo.
I need the data to be placed line by line in the memo.
This is the source code:
procedure TForm3.Timer1Timer(Sender: TObject);
var
k: Integer;
InBuffer: array[1..500] of char;
begin
for k:=1 to 500 do
InBuffer[k]:=' ';
Trim(InBuffer);
if cport.Connected = true then
begin
ComLed1.Kind := lkGreenLight;
cport.ReadStr(str,k);
Trim(str);
S:=str;
if str = '' then
begin
end
else
begin
memo1.lines.Add(str);
end;
end
else
begin
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Connected';
end;
end;
My question is what is the problem? And what is the solution for this.
TMemo.Lines.Add() adds a line. The text you add will have a line break inserted at the end of it. It is clear that you are receiving the hardware data in pieces, and you are adding each piece separately as its own line in the Memo.
To do what you are attempting, you need to either:
Read the pieces from the hardware and cache them until you detect the end of a complete message, and then Add() only complete messages to the Memo. How you do this depends on the particular protocol the hardware is using to send data to you. Does it wrap the data in STX/ETX markers? Does it delimit messages? We don't know, you have not provided any information about that. And your code is trying (unsuccessfully) to trim a lot of data away that it probably shouldn't be throwing away at all.
Don't use Add() at all. You can use the SelText property instead to avoid inserting any line breaks you don't want.
memo1.SelStart := memo1.GetTextLen;
memo1.SelLength := 0;
memo1.SelText := str;
That being said, your timer code is doing some odd things. InBuffer is filled with spaces, then (unsuccessfully) trimmed, and then completely ignored. You are passing an uninitialized k value to ReadStr(). The str value you do read is unsuccessfully trimmed before added to the Memo. You are assigning str to S and then ignoring S.
Try this instead:
procedure TForm3.Timer1Timer(Sender: TObject);
var
str: AnsiString;
begin
if cport.Connected then
begin
ComLed1.Kind := lkGreenLight;
txt_com_status1.Caption := 'Connected';
cport.ReadStr(str, 256);
str := Trim(str);
if str <> '' then
begin
memo1.SelStart := memo1.GetTextLen;
memo1.SelLength := 0;
memo1.SelText := str;
end;
end
else
begin
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Disconnected';
end;
end;
Alternatively (assuming you are using TComPort that has an OnRxChar event):
procedure TForm3.Timer1Timer(Sender: TObject);
begin
if cport.Connected then
begin
ComLed1.Kind := lkGreenLight;
txt_com_status1.Caption := 'Connected';
end
else
begin
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Disconnected';
end;
end;
procedure TForm3.cportRxChar(Sender: TObject; Count: Integer);
var
str: AnsiString;
begin
cport.ReadStr(str, Count);
str := Trim(str);
if str <> '' then
begin
memo1.SelStart := memo1.GetTextLen;
memo1.SelLength := 0;
memo1.SelText := str;
end;
end;
Edit based on new information provided in comments, try something like this:
private
buffer: AnsiString;
portConnected: boolean;
procedure TForm3.Timer1Timer(Sender: TObject);
begin
if cport.Connected then
begin
if not portConnected then
begin
portConnected := true;
buffer := '';
ComLed1.Kind := lkGreenLight;
txt_com_status1.Caption := 'Connected';
end;
end
else
begin
if portConnected then
begin
portConnected := false;
ComLed1.Kind := lkredLight;
txt_com_status1.Caption := 'Disconnected';
end;
end;
end;
procedure TForm3.cportRxChar(Sender: TObject; Count: Integer);
var
str: AnsiString;
i: integer;
begin
cport.ReadStr(str, Count);
buffer := buffer + str;
repeat
i := Pos(#10, buffer);
if i = 0 then Exit;
str := Copy(buffer, 1, i-1);
Delete(buffer, 1, i);
memo1.Lines.Add(str);
until buffer = '';
end;

How to make a screen shot of my actual window

I defined a Tactionlist which contains all actions to show/hide my forms. This could be modal (showmodal) or non modal (visible:=true). I found some code to catch the screen shots by this:
procedure GetScreenShot(shotType: TScreenShotType; var img: TJpegImage);
var
w,h: integer;
DC: HDC;
hWin: Cardinal;
r: TRect;
tmpBmp: TBitmap;
begin
hWin := 0;
case shotType of
sstActiveWindow:
begin //This is what I use
//only the active window
hWin := GetForegroundWindow;
dc := GetWindowDC(hWin);
GetWindowRect(hWin,r);
w := r.Right - r.Left;
h := r.Bottom - r.Top;
end; //sstActiveWindow
sstActiveClientArea:
begin
end; //sstActiveClientArea
sstPrimaryMonitor:
begin
end; //sstPrimaryMonitor
sstDesktop:
begin
end; //sstDesktop
else begin
Exit;
end; //case else
end; //case
//convert to jpg
tmpBmp := TBitmap.Create;
try
tmpBmp.Width := w;
tmpBmp.Height := h;
BitBlt(tmpBmp.Canvas.Handle,0,0,tmpBmp.Width,
tmpBmp.Height,DC,0,0,SRCCOPY);
img.Assign(tmpBmp);
finally
ReleaseDC(hWin,DC);
FreeAndNil(tmpBmp);
end; //try-finally
end;
My "scan" routine is as follows:
for ACnt := 0 to GenActions.ActionCount - 1 do
begin
try
LogBook.ML(Format('%d. Aktion %s gestartet',[ACnt,quotedstr(GenActions.Actions[ACnt].Name)]));
if GenActions.Actions[ACnt].Tag > 0 then
begin // Action is ready for test
TAction(GenActions.Actions[ACnt]).checked:=true;
if GenActions.Actions[ACnt].Execute then
begin
LogBook.ML(Format('%d. Aktion %s erfolgreich ausgeführt',[ACnt,quotedstr(GenActions.Actions[ACnt].Name)]));
if SaveScreens then // var boolean
begin
img:=TJPEGImage.Create;
try
GetScreenShot(sstActiveWindow,img);
img.SaveToFile(IncludeTrailingBackslash(Optionen.PictPfad.Text)+inttostr(ACnt)+'.jpg');
finally
img.Free;
end;
end;
repeat
sleep(100);
Application.ProcessMessages;
until not DM_Gen.TestTimer.Enabled ; //for modal windows a timer sends modalresult:=mrcancel
end;
end
else
begin
LogBook.ML(Format('%d Aktion %s nicht getestet',[ACnt,quotedstr(GenActions.Actions[ACnt].Name)]));
end;
except
on E: Exception do
LogBook.ML(Format('%d. Aktion hat Fehler %s gemeldet',[ACnt,E.Message]));
end;
end;
finally
LogBook.ML('Testlauf beendet');
end;
When I run this code I get for about the first 150 actions the mainform, then some other forms like the logbook or the browser or ... Nearly never the form I want.
I found some posts which recommended the use of "findwindow". Here is my problem that I don't know the exact caption of the window, because in all windows the caption is modified in the onshow event in order to show actual information.
Any ideas how can catch my actual opened window?
So a problem is to understand how my actions work. Here two typical examples:
procedure TDM_Gen.VALstVisActExecute(Sender: TObject);
begin
if Sender is TAction then
begin // set some properties
end;
ListeVeranst_2.Visible:=VALstVisAct.Checked;
end;
procedure TDM_Gen.NewVAActExecute(Sender: TObject);
var
NewVA : TNewVeranstaltung;
begin
if Sender <> nil then
begin
if Sender is TButton then
begin //do something depending on who fired
end;
end;
try
NewVA:=TNewVeranstaltung.Create(nil);
case NewVA.ShowModal of
mrOk:
begin // e.g. refresh some lists
end;
mrCancel:
begin // clean up
end;
end;
finally
NewVA.Free;
end;
end;
The caption of the window is set during the onshow event by:
caption:=Format('This is window %s %s',[Param1, Param2]);
Problem you are facing is due to ShowModal method that is blocking call. That means that all subsequent code after that call will start executing after the form is closed.
Code flow in following simplified example:
MyAction.Execute;
CaptureScreen;
procedure TSomeForm.MyActionExecute(Sender: TObject);
var frm: TForm;
begin
frm := TForm.Create(nil);
try
frm.ShowModal; // this call blocks execution of subsequent code in this method until form is closed
finally
frm.Free;
end;
end;
will be MyAction.Execute -> frm.ShowModal -> frm.Close -> frm.Free -> CaptureScreen
You will have to initiate screen capturing from within your modal form in order to capture its screen.

Evaluate Email with Indy 10 and DELPHI

I use the following code to eval the msg. content (body / lines) of an E Mail msg received with the INDY 10 components
function LinesFromMsg(aMsg: TIdMessage): TStrings;
var
i: Integer;
begin
for i := 0 to aMsg.MessageParts.AttachmentCount-1 do
begin
if (amsg.MessageParts.Items[i].ContentType ='HTML') then
begin
if (amsg.MessageParts.Items[i] is Tidtext) then
Result := TidText(amsg.MessageParts.Items[i]).body;
end;
end;
end;
regarding this code I have 2 questions :
a) is this the correct way of finding the Tlines part in an arbitray mail message ?
( consider the advice shown at INDY 10 EMAIL MSG PARTS )
b) where can I find a tutorial of all the different Contenttype string values?
The correct ContentType value to look for is text/html. Use Indy's IsHeaderMediaType() function to check it, as the ContentType value may have additional attributes associated with it that your comparison needs to ignore.
You also need to take the TIdMessage.ContentType into account as well, as HTML emails may not be MIME encoded and thus not use the TIdMessage.MessageParts` collection at all.
And lastly, you loop needs to use the MessageParts.Count property instead of the MessageParts.AttachmentsCount property.
Try this:
function HTMLFromMsg(aMsg: TIdMessage): TStrings;
var
i: Integer;
Part: TIdMessagePart;
begin
Result := nil;
if IsHeaderMediaType(aMsg.ContentType, 'text/html') then
begin
Result := aMsg.Body;
Exit;
end;
for i := 0 to aMsg.MessageParts.Count-1 do
begin
Part := aMsg.MessageParts.Items[i];
if (Part is TIdText) and IsHeaderMediaType(Part.ContentType, 'text/html') then
begin
Result := TIdText(Part).Body;
Exit;
end;
end;
end;
With that said, this is technically not the correct way to handle MIME. Officially, a conforming reader is supposed to loop backwards through the MIME parts, as they are ordered from the simpliest form downwards towards the most complex form. So you loop backwards, taking MIME nesting into account, looking for the most complex form you support. Something more like this (untested):
procedure DisplayPlainText(Body: TStrings);
begin
// display plain text as needed...
end;
procedure DisplayHTML(Body: TStrings);
begin
// display html as needed...
end;
procedure DisplayMultiPartAlternative(aMsg: TIdMessage; aParentIndex, aLastIndex: Integer);
var
Part: TIdMessagePart;
i: Integer:
begin
for i := aLastIndex-1 downto aParentIndex+1 do
begin
Part := aMsg.MessageParts.Items[i];
if (Part.ParentPart = aParentIndex) and (Part is TIdText) then
begin
if IsHeaderMediaType(Part.ContentType, 'text/html') then
begin
DisplayHTML(TIdText(Part).Body);
Exit;
end;
if IsHeaderMediaType(Part.ContentType, 'text/plain') then
begin
DisplayPlainText(TIdText(Part).Body);
Exit;
end;
end;
end;
// nothing supported to display...
end;
procedure DisplayMultiPartMixed(aMsg: TIdMessage; aParentIndex, aLastIndex: Integer);
var
Part: TIdMessagePart;
i: Integer;
begin
for i := aLastIndex-1 downto aParentIndex+1 do
begin
Part := aMsg.MessageParts.Items[i];
if (Part.ParentPart = aParentIndex) and (Part is TIdText) then
begin
if IsHeaderMediaType(Part.ContentType, 'multipart/alternative') then
begin
DisplayMultiPartAlternative(aMsg, ParentPart.Index, aLastIndex);
Exit;
end;
if IsHeaderMediaType(ParentPart.ContentType, 'text/html') then
begin
DisplayHTML(TIdText(Part).Body);
Exit;
end;
if IsHeaderMediaType(Part.ContentType, 'text/plain') then
begin
DisplayPlainText(TIdText(Part).Body);
Exit;
end;
aLastIndex := i;
end;
end;
// nothing supported to display...
end;
procedure DisplayMsg(aMsg: TIdMessage);
var
ContentType: string;
begin
ContentType := ExtractHeaderMediaType(aMsg.ContentType);
case PosInStrArray(ContentType, ['multipart/mixed', 'multipart/alternative', 'text/html', 'text/plain'], False) of
0: begin
DisplayMultiPartAlternative(aMsg, -1, aMsg.MessageParts.Count);
Exit;
end;
1: begin
DisplayMultiPartMixed(aMsg, -1, aMsg.MessageParts.Count);
Exit;
end;
2: begin
DisplayHTML(aMsg.Body);
Exit;
end;
3: begin
DisplayPlainText(aMsg.Body);
Exit;
end;
else
// nothing supported to display...
end;
end;

Resources