I have a source that promises to get the active url from any browser using UIAutomation, but I have difficulty about how to call the main function and show result in a ListBox for example. Then, how would it?
Here is my code:
uses
UIAutomationClient_TLB, activeX;
var
Firefox_quebrou: boolean;
function GetURL(hTargetWnd: HWND): string;
function Enumerar(pParent: IUIAutomationElement; Scope: TreeScope; pCondition: IUIAutomationCondition): String;
var
found : IUIAutomationElementArray;
ALen : Integer;
i : Integer;
iElement : IUIAutomationElement;
retorno: integer;
value : WideString;
iInter: IInterface;
ValPattern : IUIAutomationValuePattern;
begin
Result := '';
Firefox_quebrou := false;
if pParent = nil then
Exit;
pParent.FindAll(Scope, pCondition, found);
found.Get_Length(ALen);
for i := 1 to ALen - 1 do
begin
found.GetElement(i, iElement);
iElement.Get_CurrentControlType(retorno);
if (
(retorno = UIA_EditControlTypeId) or
(retorno = UIA_GroupControlTypeId)
) then //UIA_DocumentControlTypeId
begin
iElement.GetCurrentPattern(UIA_ValuePatternId, iInter);
if Assigned(iInter) then
begin
if iInter.QueryInterface(IID_IUIAutomationValuePattern, ValPattern) = S_OK then
begin
ValPattern.Get_CurrentValue(value);
Result := trim(value);
Firefox_quebrou := true;
Break;
end;
end;
end;
if not Firefox_quebrou then
begin
Result := Enumerar(iElement, Scope, pCondition);
end;
end;
end;
var
UIAuto : IUIAutomation;
Ret : Integer;
RootElement : IUIAutomationElement;
Scope : TreeScope;
varProp : OleVariant;
pCondition : IUIAutomationCondition;
begin
Result := '';
try
UIAuto := CoCUIAutomation.Create;
if Succeeded(UIAuto.ElementFromHandle(hTargetWnd, RootElement)) then
begin
TVariantArg(varProp).vt := VT_BOOL;
TVariantArg(varProp).vbool := True;
UIAuto.CreatePropertyCondition(UIA_IsControlElementPropertyId,
varProp,
pCondition);
Scope := TreeScope_Element or TreeScope_Children;
Result := Enumerar(RootElement, Scope, pCondition);
end;
except
Result := '';
end;
end;
Related
In a 32-bit VCL Application in Windows 10 in Delphi 11 Alexandria, I am trying to get the window handle of a running main task from the task's module path:
type
TFindWindowRec = record
ModuleToFind: string;
FoundHWnd: HWND;
end;
function EnumWindowsCallBack(aHandle: HWND; var FindWindowRec: TFindWindowRec): BOOL; stdcall;
const
C_FileNameLength = 256;
var
WinFileName: string;
PID, hProcess: DWORD;
Len: Byte;
begin
Result := True;
SetLength(WinFileName, C_FileNameLength);
GetWindowThreadProcessId(aHandle, PID);
hProcess := OpenProcess(PROCESS_ALL_ACCESS, False, PID);
Len := GetModuleFileNameEx(hProcess, 0, PChar(WinFileName), C_FileNameLength);
if Len > 0 then
begin
SetLength(WinFileName, Len);
if SameText(WinFileName, FindWindowRec.ModuleToFind) then
begin
Result := False;
FindWindowRec.FoundHWnd := aHandle;
end;
end;
end;
var
FindWindowRec: TFindWindowRec;
function TformMain.GetmainWindowHandleFRomProcessPath(aProcessPath: string): HWND;
begin
Result := 0;
CodeSite.Send('TformMain.GetmainWindowHandleFRomProcessPath: aProcessPath', aProcessPath);
FindWindowRec.ModuleToFind := aProcessPath;
FindWindowRec.FoundHWnd := 0;
EnumWindows(#EnumWindowsCallback, Integer(#FindWindowRec));
if FindWindowRec.FoundHWnd <> 0 then
begin
Result := FindWindowRec.FoundHWnd;
CodeSite.Send('TformMain.GetmainWindowHandleFRomProcessPath: Result', Result);
end;
end;
When I do this with:
GetmainWindowHandleFRomProcessPath('c:\windows\system32\notepad.exe');
... then I get the correct window handle.
When I do this with:
GetmainWindowHandleFRomProcessPath('C:\Program Files (x86)\Embarcadero\Studio\22.0\bin\bds.exe');
... then I get a WRONG (non-existing) window handle!
Why is this happening? How do I get the correct window handle?
The discussion with Remy and Andreas lead me to this successful working answer:
type
TFindWindowRec = record
ModuleToFind: string;
FoundHWnd: HWND;
end;
// The `RzShellUtils` unit is from Ray Konopka's Signature Library available from GetIt:
function PathsAreSamePIDL(const Path1, Path2: string): Boolean;
begin
var AIL1: PItemIdList;
var AIL2: PItemIdList;
RzShellUtils.ShellGetIdListFromPath(Path1, AIL1);
RzShellUtils.ShellGetIdListFromPath(Path2, AIL2);
var CompResult:= RzShellUtils.CompareAbsIdLists(AIL1, AIL2);
Result := CompResult = 0;
end;
function EnumWindowsCallBack(aHandle: HWND; var FindWindowRec: TFindWindowRec): BOOL; stdcall;
const
C_FileNameLength = MAX_PATH;
PROCESS_QUERY_LIMITED_INFORMATION = $1000;
var
WinFileName: string;
PID, hProcess: DWORD;
Len: Byte;
begin
Result := True;
SetLength(WinFileName, C_FileNameLength);
GetWindowThreadProcessId(aHandle, PID);
hProcess := OpenProcess(PROCESS_QUERY_LIMITED_INFORMATION, False, PID);
Len := GetModuleFileNameEx(hProcess, 0, PChar(WinFileName), C_FileNameLength);
CloseHandle(hProcess);
if Len > 0 then
begin
SetLength(WinFileName, Len);
//if SameText(WinFileName, FindWindowRec.ModuleToFind) then
if PathsAreSamePIDL(WinFileName, FindWindowRec.ModuleToFind) then
begin
var IsVisible := IsWindowVisible(aHandle);
if not IsVisible then EXIT;
var IsOwned := GetWindow(aHandle, GW_OWNER) <> 0;
if IsOwned then EXIT;
var IsAppWindow := GetWindowLongPtr(aHandle, GWL_EXSTYLE) and WS_EX_APPWINDOW <> 0;
if not IsAppWindow then EXIT;
Result := False;
FindWindowRec.FoundHWnd := aHandle;
end;
end;
end;
function TformMain.GetMainWindowHandleFromProcessPath(aProcessPath: string): HWND;
var
FindWindowRec: TFindWindowRec;
begin
Result := 0;
FindWindowRec.ModuleToFind := aProcessPath;
FindWindowRec.FoundHWnd := 0;
EnumWindows(#EnumWindowsCallback, LPARAM(#FindWindowRec));
if FindWindowRec.FoundHWnd <> 0 then
begin
Result := FindWindowRec.FoundHWnd;
end;
end;
I don't understand why the person who moved the discussion to another page deleted the latest comments. Was there anything forbidden in those deleted comments?
Again: Thank you to Remy and Andreas!
I want capture the url of active window based in a substring and add to Memo only if sActiveURL is different of sOldURL.
The trouble in my code is that always is added to Memo the same url ignoring the verification if sActiveURL <> sOldURL.
How fix this?
Main:
type
TForm1 = class(TForm)
tmr1: TTimer;
mmo1: TMemo;
procedure tmr1Timer(Sender: TObject);
private
{ Private declarations }
sActiveURL,sOldURL : string;
public
{ Public declarations }
end;
var
Form1: TForm1;
Flag: Boolean;
implementation
uses
UIAutomationClient_TLB, Activex, StrUtils;
{$R *.dfm}
function GetURL(hTargetWnd: HWND): string;
function Enumerar(pParent: IUIAutomationElement; Scope: TreeScope; pCondition: IUIAutomationCondition): String;
var
found : IUIAutomationElementArray;
ALen : Integer;
i : Integer;
iElement : IUIAutomationElement;
retorno: integer;
value : WideString;
iInter: IInterface;
ValPattern : IUIAutomationValuePattern;
begin
Result := '';
Flag := false;
if pParent = nil then
Exit;
pParent.FindAll(Scope, pCondition, found);
found.Get_Length(ALen);
for i := 1 to ALen - 1 do
begin
found.GetElement(i, iElement);
iElement.Get_CurrentControlType(retorno);
if (
(retorno = UIA_EditControlTypeId) or
(retorno = UIA_GroupControlTypeId)
) then
begin
iElement.GetCurrentPattern(UIA_ValuePatternId, iInter);
if Assigned(iInter) then
begin
if iInter.QueryInterface(IID_IUIAutomationValuePattern, ValPattern) = S_OK then
begin
ValPattern.Get_CurrentValue(value);
Result := trim(value);
Flag := true;
Break;
end;
end;
end;
if not Flag then
begin
Result := Enumerar(iElement, Scope, pCondition);
end;
end;
end;
var
UIAuto : IUIAutomation;
Ret : Integer;
RootElement : IUIAutomationElement;
Scope : TreeScope;
varProp : OleVariant;
pCondition : IUIAutomationCondition;
begin
Result := '';
try
UIAuto := CoCUIAutomation.Create;
if Succeeded(UIAuto.ElementFromHandle(hTargetWnd, RootElement)) then
begin
TVariantArg(varProp).vt := VT_BOOL;
TVariantArg(varProp).vbool := True;
UIAuto.CreatePropertyCondition(UIA_IsControlElementPropertyId,
varProp,
pCondition);
Scope := TreeScope_Element or TreeScope_Children;
Result := Enumerar(RootElement, Scope, pCondition);
end;
except
Result := '';
end;
end;
procedure TForm1.tmr1Timer(Sender: TObject);
begin
sActiveURL := GetURL(GetForegroundWindow);
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add('['+sActiveURL+']<'+DateToStr(Date)+'>');
end;
end;
end;
UIAutomationClient_TLB.pas
EDITION:
On debug i discovered that none value is attrib to sOldURL variable.
procedure TForm1.tmr1Timer(Sender: TObject);
var
sActiveURL,sOldURL : string;
begin
sActiveURL := GetURL(GetForegroundWindow);
mmo1.Lines.Add('[sOldURL = '+sOldURL+' ]');
mmo1.Lines.Add('[sActiveURL = '+sActiveURL+' ]');
mmo1.Lines.Add('');
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add(sActiveURL);
mmo1.Lines.Add('');
mmo1.Lines.Add('');
end;
end;
end;
The reason is as I shortly described in comments and is visible when the focused window is not your browser, for example your applications wiindow with the mmo1: TMemo:
GetForegroundWindow() returns the window that has focus.
Your GetURL(GetForegroundWindow) searches for an edit control (UIA_EditControlTypeId), of the focused window, and finds your memo control and returns the content of the memo.
Further, if you change focus to your browser, its URL will be correctly recorded in the memo, and if you return focus to your application, the condition if AnsiContainsText(sActiveURL, 'stackoverflow.com') will be true.
You then write to the memo, adding what you think is a real URL, and then this will be repeated for every timer event.
You need to only check the real browser window (skip all other) for its current URL. Try this, if you are using IE, otherwise you must modify FindWindow():
procedure TForm24.tmr1Timer(Sender: TObject);
var //
hIEWnd: HWND; //
begin
hIEWnd := FindWindow('IEFrame', nil); //
sActiveURL := GetURL(hIEWnd); //
// sActiveURL := GetURL(GetForegroundWindow);
if sActiveURL <> sOldURL then
begin
if AnsiContainsText(sActiveURL, 'stackoverflow.com') then
begin
sOldURL := sActiveURL;
mmo1.Lines.Add('[' + sActiveURL + ']<' + DateToStr(Date) + '>');
end;
end;
end;
Modified lines are marked with //
I want to get and show the name and extension of selected file in explorer by delphi7.
I use below code for show caption of active window but i need selected file name in active window.
function ActiveCaption: string;
var
Handle: THandle;
Len: LongInt;
Title: string;
begin
Result := '';
Handle := GetForegroundWindow;
if Handle <> 0 then
begin
Len := GetWindowTextLength(Handle) + 1;
SetLength(Title, Len);
GetWindowText(Handle, PChar(Title), Len);
ActiveCaption := TrimRight(Title);
end;
end;
procedure TForm1.Timer1Timer(Sender: TObject);
begin
Label1.Caption := ActiveCaption;
end;
The only way I know of is to use the Active-X IShellWindows and IWebBrowser Interfaces to to that.
First, you have to import the "Microsoft Internet Controls" Active-X (via the Component Menu). By that you will get a unit called "SHDocVW_TLB". Put this unit and the ActiveX unit in your uses clause.
Than you can use the following two functions to retrieve the selected file from the window handle provided:
The first function does a rough test if the given handle belongs to an explorer window
function isexplorerwindow(exwnd: hwnd): boolean;
var
p: array[0..max_path] of Char;
begin
GetClassName(exwnd, p, SizeOf(p));
result := ((strcomp(p, 'CabinetWClass') = 0) or (strcomp(p, 'ExploreWClass') = 0));
end;
And the second function retrieves the name of the nth selected file:
function getexplorerselectedfile(exwnd: hwnd; nr: integer): string;
var
pvShell: IShellWindows;
pvWeb2: IWebBrowser2;
ovIE: OleVariant;
psp: IServiceProvider;
psb: IShellBrowser;
isw: IShellView;
ido: IDataObject;
FmtEtc: TFormatEtc;
Medium: TStgMedium;
dwcount: integer;
n: integer;
p: array[0..max_path] of Char;
s: string;
found: boolean;
begin
found := false;
result := '';
s :='';
try
pvShell := CoShellWindows.Create;
for dwcount := 0 to Pred(pvShell.count) do
begin
ovIE := pvShell.Item(dwcount);
if (ovIE.hwnd = exwnd) or ((exwnd = 0) and isexplorerwindow(ovIE.hwnd)) then
begin
found := true;
if (IDispatch(ovIE).QueryInterface(IWebBrowser2, pvWeb2) = S_OK) then
begin
psp := (pvWeb2 as IServiceProvider);
psp.QueryService(IID_IShellBrowser, IID_IShellBrowser, psb);
psb.QueryActiveShellView(isw);
if isw.GetItemObject(SVGIO_SELECTION, IDataObject, pointer(ido)) = S_OK then
begin
try
FmtEtc.cfFormat := CF_HDROP;
FmtEtc.ptd := nil;
FmtEtc.dwAspect := DVASPECT_CONTENT;
FmtEtc.lindex := -1;
FmtEtc.tymed := TYMED_HGLOBAL;
ido.GetData(FmtEtc, Medium);
GlobalLock(Medium.hGlobal);
try
n := DragQueryFile(Medium.hGlobal, $FFFFFFFF, nil, 0);
if nr < n then
begin
DragQueryFile(Medium.hGlobal, nr, p, max_path);
s := strpas(p);
end;
finally
DragFinish(Medium.hGlobal);
GlobalUnLock(Medium.hGlobal);
end;
finally
ReleaseStgMedium(Medium);
end;
end;
pvWeb2 := nil;
end;
end;
ovIE := Unassigned;
if found then
break;
end;
pvShell := nil;
finally
result := s;
end;
end;
To test this code create a new project and place a button and a memo on the form.
Add the following units to the uses clause:
USES SHDocVW_TLB, ShlObj, activex, shellapi;
And add this code to the button event handler:
PROCEDURE TForm2.Button1Click(Sender: TObject);
VAR
wnd, exwnd: hwnd;
n: integer;
s: STRING;
BEGIN
exwnd := 0;
wnd := getwindow(getdesktopwindow, gw_child);
REPEAT
IF isexplorerwindow(wnd) THEN
BEGIN
exwnd := wnd;
break;
END;
wnd := getwindow(wnd, gw_hwndnext);
UNTIL (wnd = 0) OR (exwnd <> 0);
IF exwnd <> 0 THEN
BEGIN
n := 0;
REPEAT
s := getexplorerselectedfile(exwnd, n);
memo1.Lines.Add(s);
inc(n);
UNTIL s = '';
END;
END;
If you press the button, the memo will contain the selected files of the first open explorer window it finds. Of course you should have an explorer window open with at least one file selected.
Anyone can help how can I transform this to work with tcxchecklistbox?
My Save procedure looks like...
procedure Tfrm_A.SaveCheckListBoxData(S: TMemoryStream;
CheckListBox: TCheckListBox);
var
i: longint;
b: boolean;
buf : string;
begin
S.Clear;
buf := CheckListBox.Items.Text;
i := Length(buf);
S.Write(i, SizeOf(i));
if i > 0 then begin
S.Write(buf[1], i);
for i:= 0 to Pred(CheckListBox.Items.Count) do
begin
b:= CheckListBox.Checked[i];
s.Write(b,1);
end;
end;
end;
My load procedure looks like...
procedure Tfrm_A.LoadCheckListBoxData(S: TMemoryStream;
CheckListBox: TChecklistBox);
var
i: longint;
b: Boolean;
buf : string;
begin
S.Position := 0;
S.Read(i, SizeOf(i));
if i > 0 then begin
SetLength(buf, i);
S.Read(buf[1], i);
CheckListBox.Items.Text := buf;
for i:= 0 to Pred(CheckListBox.Items.Count) do
begin
s.Read(b,1);
CheckListBox.Checked[i] := b;
end;
end;
end;
My problem is
buf := CheckListBox.Items.Text;
TcxChecklistbox has checklistbox.items[Index].textproperty
Thanks for the help!
You can use a TStringStream to do this. Basically, it's just a question of iterating the cxCheckBoxList Items and writing a character to the StringStream indicating whether the checkbox is checked, and then reading the stream back a character at a time.
function StateToString(Checked : Boolean) : String;
begin
if Checked then
Result := '+'
else
Result := '-';
end;
procedure TForm1.SaveStatesToStream(SS : TStringStream);
var
i : integer;
begin
SS.Clear;
SS.Position := 0;
for i := 0 to cxCheckListBox1.Items.Count - 1 do begin
SS.WriteString(StateToString(cxCheckListBox1.Items[i].Checked));
end;
Memo1.Lines.Add('>' + SS.DataString + '<');
end;
procedure TForm1.LoadStatesFromStream(SS : TStringStream);
var
i : integer;
S : String;
begin
CheckBoxList.ClearCheckmarks;
SS.Position := 0;
i := 0;
while (i <= cxCheckListBox1.Items.Count - 1) and (SS.Position < SS.Size) do begin
S := SS.ReadString(1);
cxCheckListBox1.Items[i].Checked := S = '+';
Inc(i);
end;
end;
Tested in Delphi Seattle
I have run into trouble trying to access the pointer to a record type in my record data using Delphi's RTTI.
Please check the sample code that i have been working on.
// Dummy Header
typDummyHeader = ^tysDummyHeader;
tysDummyHeader = record
MessageCode : Integer;
MessageLength : Integer;
end;
// Dummy record having header and trailer
tysDummyRecord = record
Header : tysDummyHeader;
BotAmount : Double;
SoldAmount : Double;
SoldQty : Int64;
BotQty : Int64;
Tailer : typDummyHeader; // pointer to Dummy Header
end;
TclDummy = class
class function GetFieldValue<T>(const pipInstance : Pointer;
const piclField : TRttiField) : string;
class function ParseAndReturnString<T>(piclObject : T) : string;
end;
var
frmRTTITest: TfrmRTTITest;
implementation
{$R *.dfm}
procedure TfrmRTTITest.FormCreate(Sender: TObject);
var
losDummyRecord : tysDummyRecord;
begin
FillChar(losDummyRecord, SizeOf(tysDummyRecord), #0);
losDummyRecord.Header.MessageCode := 5000;
losDummyRecord.Header.MessageLength := 54433;
losDummyRecord.BotAmount := 19.45;
losDummyRecord.SoldAmount := 34.22;
losDummyRecord.SoldQty := 102;
losDummyRecord.BotQty := 334;
losDummyRecord.Tailer := #losDummyRecord.Header;
ShowMessage(TclDummy.ParseAndReturnString<tysDummyRecord>(losDummyRecord));
end;
class function TclDummy.GetFieldValue<T>(const pipInstance : Pointer;
const piclField : TRttiField) : string;
begin
case piclField.FieldType.TypeKind of
tkFloat: Result := FloatToStr(piclField.GetValue(pipInstance).AsExtended);
tkInt64: Result := IntToStr(piclField.GetValue(pipInstance).AsInt64);
tkInteger: Result := IntToStr(piclField.GetValue(pipInstance).AsInteger);
tkString: Result := Trim(piclField.GetValue(pipInstance).AsString);
end;
end;
class function TclDummy.ParseAndReturnString<T>(piclObject : T) : string;
var
losContext : TRttiContext;
losContextType : TRttiType;
loclField : TRttiField;
losRecordRTTI : TRttiRecordType;
loclRecordField : TRttiField;
losPointerType : TRttiPointerType;
losValue : TValue;
begin
Result := EmptyStr;
losContext := TRttiContext.Create;
losContextType := losContext.GetType(TypeInfo(T));
if losContextType.TypeKind = tkRecord then
begin
for loclField in losContextType.GetFields do
begin
case loclField.FieldType.TypeKind of
tkRecord:
begin
losRecordRTTI := loclField.FieldType.AsRecord;
for loclRecordField in losRecordRTTI.GetFields do
begin
Result := Result + '|' + GetFieldValue<T>(Addr(piclObject), loclRecordField);
end;
end; // tkRecord
tkPointer:
begin
losPointerType := loclField.FieldType as TRttiPointerType;
// Check only record type pointers.
if losPointerType.ReferredType.TypeKind = tkRecord then
begin
losValue := loclField.GetValue(Addr(piclObject));
if (not losValue.IsEmpty) then
begin
for loclRecordField in losPointerType.ReferredType.GetFields do
begin
// Result := Result + '|' + ???????????
end;
end;
end;
end; // tkPointer
else
Result := Result + '|' + GetFieldValue<T>(Addr(piclObject), loclField);
end;
end;
end;
losContext.Free;
end;
In the above sample, when the field is tkPointer which is pointing to a record type, how do I read the values from that ?
Result := Result + '|' + GetFieldValue<T>(Addr(piclObject),loclRecordField);
should do the job.
Sorry for my poor English.
Answer of #bummi works but is not right.
It depends on usage.
If you use next code all works well:
var
losDummyRecord : tysDummyRecord;
begin
FillChar(losDummyRecord, SizeOf(tysDummyRecord), #0);
losDummyRecord.Header.MessageCode := 5000;
losDummyRecord.Header.MessageLength := 54433;
losDummyRecord.BotAmount := 19.45;
losDummyRecord.SoldAmount := 34.22;
losDummyRecord.SoldQty := 102;
losDummyRecord.BotQty := 334;
losDummyRecord.Tailer := #losDummyRecord.Header;
ShowMessage(TclDummy.ParseAndReturnString<tysDummyRecord>(losDummyRecord));
But if you use for example this code, parsing don't work correctly:
var
losDummyRecord : tysDummyRecord;
ExternalHeaderVar: tysDummyHeader;
begin
ExternalHeaderVar.MessageCode := 23;
ExternalHeaderVar.MessageLength := 25;
FillChar(losDummyRecord, SizeOf(tysDummyRecord), #0);
losDummyRecord.Header.MessageCode := 5000;
losDummyRecord.Header.MessageLength := 54433;
losDummyRecord.BotAmount := 19.45;
losDummyRecord.SoldAmount := 34.22;
losDummyRecord.SoldQty := 102;
losDummyRecord.BotQty := 334;
losDummyRecord.Tailer := #ExternalHeaderVar;
ShowMessage(TclDummy.ParseAndReturnString<tysDummyRecord>(losDummyRecord));
Solutions is simple and works in both cases well and prevents unexpected errors in the future use:
tkPointer:
begin
losPointerType := loclField.FieldType as TRttiPointerType;
// Check only record type pointers.
if losPointerType.ReferredType.TypeKind = tkRecord then
begin
losValue := loclField.GetValue(Addr(piclObject));
if (not losValue.IsEmpty) then
begin
losValue.ExtractRawDataNoCopy(#NativeIntVar);
for loclRecordField in losPointerType.ReferredType.GetFields do
begin
Result := Result + '|' + GetFieldValue<T>(Pointer(NativeIntVar),loclRecordField);
end;
end;
end;
end; // tkPointer