How to make a screen shot of my actual window - delphi

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.

Related

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;

Wait for a global variable to change its value

I have created following abstract code where the user has 2 buttons:
One button is starting some kind of process. The global variable PleaseStop will tell the running process that it should stop its work.
The other button sets the global variable PleaseStop which will tell the procedure to stop.
-
var
PleaseStop: boolean;
IsRunning: boolean;
procedure TForm1.RunActionClick(Sender: TObject);
var
rnd: integer;
tic: Cardinal;
begin
try
IsRunning := true;
rnd := Random(100);
while not PleaseStop do
begin
tic := GetTickCount;
while (GetTickCount-tic < 1000) and not PleaseStop do
begin
Application.ProcessMessages;
Sleep(10);
end;
Memo1.Lines.Add(IntToStr(rnd));
end;
finally
IsRunning := false;
PleaseStop := false;
end;
end;
procedure TForm1.StopBtnClick(Sender: TObject);
begin
PleaseStop := true;
end;
Everything works as expected.
Now there will be problems if the user doesn't click the Stop button, but instead clicks the Run button again (which should be allowed).
I have now modified my code like this:
var
PleaseStop: boolean;
IsRunning: boolean;
procedure TForm1.Button1Click(Sender: TObject);
var
rnd: integer;
tic: Cardinal;
begin
// ---- BEGIN NEW ----
if IsRunning then
begin
PleaseStop := true; // End the previous actions
while PleaseStop do // Wait until the previous actions are done
begin
// TODO: this loop goes forever. PleaseStop will never become false
Application.ProcessMessages;
Sleep(10);
end;
// Now we can continue
end;
// ---- END NEW ----
try
IsRunning := true;
rnd := Random(100);
while not PleaseStop do
begin
tic := GetTickCount;
while (GetTickCount-tic < 1000) and not PleaseStop do
begin
Application.ProcessMessages;
Sleep(10);
end;
Memo1.Lines.Add(IntToStr(rnd));
end;
finally
IsRunning := false;
PleaseStop := false;
end;
end;
procedure TForm1.Button2Click(Sender: TObject);
begin
PleaseStop := true;
end;
Clicking the Start button again will cause a deadlock.
I assume the compiler thinks that while PleaseStop do is equal to while true do since I just set PleaseStop to true earlier. But in fact, this variable should be monitored...
I also tried putting [volatile] in front of the variables, and make them member of TForm1, but that doesn't work either.
Why didn't I use threads?
The code is heavily VCL dependent.
The run button will start a dia show. Every time, the run button is clicked, a random picture folder will be chosen.
So, when the user doesn't like the pictures, he will click "Run" again to switch to a new folder and start the new dia show automatically. The previous run should be stoppped therefore.
Your diagnosis is not exactly accurate, ProcessMessages, simply, cannot cause a previously retrieved message's processing to continue. You have to stop processing and let the execution continue from where re-entrancy occurred. Re-entrancy is the primary avoidance reason of Application.ProcessMessages, and you're doing it on purpose. Hard to work it out...
If you don't want to use synchronization and threading, you can use a timer instead. The code will be much simpler too.
procedure TForm1.FormCreate(Sender: TObject);
begin
Timer1.Enabled := False;
Randomize;
end;
var
rnd: Integer;
procedure TForm1.StartClick(Sender: TObject);
begin
rnd := Random(100);
Timer1.Enabled := True;
end;
procedure TForm1.StopClick(Sender: TObject);
begin
Timer1.Enabled := False;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Memo1.Lines.Add(IntToStr(rnd));
end;
Try to rewrite your event handler like this:
var Needtorestart:Boolean = false;
procedure TForm1.Button1Click(Sender: TObject);
var
rnd: integer;
tic: Cardinal;
begin
// ---- BEGIN NEW ----
if IsRunning then
begin
PleaseStop := true; // End the previous action
Needtorestart := true;
Exit;
// Now we can continue
end;
// ---- END NEW ----
try
repeat
IsRunning := true;
rnd := Random(100);
while not PleaseStop do
begin
Tic := GetTickCount;
while (GetTickCount-tic < 1000) and not PleaseStop do
begin
Application.ProcessMessages;
Sleep(10);
end;
Memo1.Lines.Add(IntToStr(rnd));
end;
PleaseStop := false;
until not Needtorestart;
finally
IsRunning := false;
PleaseStop := false;
Needtorestart := false;
end;
end;

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;

Chromium: How to get all form of a loaded page

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;

Problem with Keyboard hook proc

The background: My form has a TWebBrowser. I want to close the form with ESC but the TWebBrowser eats the keystrokes - so I decided to go with a keyboard hook.
The problem is that the Form can be open in multiple instances at the same time.
No matter what I do, in some situations, if there are two instances open of my form, closing one of them closes the other as well.
I've attached some sample code. Any ideas on what causes the issue?
var
EmailDetailsForm: TEmailDetailsForm;
KeyboardHook: HHook;
implementation
function KeyboardHookProc(Code: Integer; wParam, lParam: LongInt): LongInt; stdcall;
var
hWnd: THandle;
I: Integer;
F: TForm;
begin
if Code < 0 then
Result := CallNextHookEx(KeyboardHook, Code, wParam, lParam)
else begin
case wParam of
VK_ESCAPE:
if (lParam and $80000000) <> $00000000 then
begin
hWnd := GetForegroundWindow;
for I := 0 to Screen.FormCount - 1 do
begin
F := Screen.Forms[I];
if F.Handle = hWnd then
if F is TEmailDetailsForm then
begin
PostMessage(hWnd, WM_CLOSE, 0, 0);
Result := HC_SKIP;
break;
end;
end; //for
end; //if
else
Result := CallNextHookEx(KeyboardHook, Code, wParam, lParam);
end; //case
end; //if
end;
function TEmailDetailsForm.CheckInstance: Boolean;
var
I, J: Integer;
F: TForm;
begin
Result := false;
J := 0;
for I := 0 to Screen.FormCount - 1 do
begin
F := Screen.Forms[I];
if F is TEmailDetailsForm then
begin
J := J + 1;
if J = 2 then
begin
Result := true;
break;
end;
end;
end;
end;
procedure TEmailDetailsForm.FormCreate(Sender: TObject);
begin
if not CheckInstance then
KeyboardHook := SetWindowsHookEx(WH_KEYBOARD, #KeyboardHookProc, 0, GetCurrentThreadId());
end;
procedure TEmailDetailsForm.FormDestroy(Sender: TObject);
begin
if not CheckInstance then
UnHookWindowsHookEx(KeyboardHook);
end;
You could do this with TApplicationEvents.OnMessage instead. Drop a TApplicationEvents component on your application's main form with this code:
procedure TMainForm.ApplicationEvents1Message(var Msg: tagMSG;
var Handled: Boolean);
var
C: TControl;
H: HWND;
begin
if (Msg.message = WM_KEYDOWN) and (Msg.wParam = VK_ESCAPE) then begin
H := Msg.hwnd;
while GetParent(H) <> 0 do
H := GetParent(H);
C := FindControl(H);
if C is TEmailDetailsForm then begin
TEmailDetailsForm(C).Close;
Handled := True;
end;
end;
end;
If you want to keep using a keyboard hook instead, you should only hook it once, rather than once for each form, especially since you're overwriting a global variable. Try adding a HookCount global variable, and only hook/unhook if it's the only form.
The background: My form has a
TWebBrowser. I want to close the form
with ESC but the TWebBrowser eats the
keystrokes - so I decided to go with a
keyboard hook.
There might be a simpler solution. Have you tried setting the form's KeyPreview property to True?
Well, both forms are signed up to receive the keyboard notice, so they both close.
You need to put code in there to decide "is this ESC for me?". Maybe by determining if you're the window with focus or not. If it's not your ESCape, then don't close.
But, this all seems rather drastic. There must be a simpler, non-obtrusive way to detect the ESC within THIS APP, without having to monitor the keyboard for the whole system.

Resources