In Internet Explorer, I can use IHtmlDocument2 to get the html document.
function GetCurrentBrowserDOM: WideString;
var
hr: HRESULT;
CurrentIE: IWebbrowser2;
Wnd: HWND;
WndChild:HWND;
document: IDispatch;
RootNode: IHTMLDocument2;
innerHtml: WideString;
begin
Result := '';
Wnd := GetForegroundWindow;
WndChild := FindWindowEx(Wnd, 0,'Frame Tab', nil);
WndChild := FindWindowEx(WndChild, 0,'TabWindowClass', nil);
WndChild := FindWindowEX(WndChild, 0, 'Shell DocObject View', nil);
WndChild := FindWindowEX(WndChild, 0, 'Internet Explorer_Server', nil);//find Internet
CoInitialize(nil);
try
hr := GetIEFromHWND(WndChild, CurrentIE);
if hr = S_OK then
begin
document := CurrentIE.Document;
document.QueryInterface(IID_IHTMLDocument2, RootNode);
innerHtml := RootNode.body.innerHTML;
end;
finally
CoUninitialize;
end;
end;
function GetIEFromHWND(WHandle: HWND; var IE: IWebbrowser2): HRESULT;
type
TObjectFromLResult = function(LRESULT: LRESULT; const IID: TGUID; wParam: WPARAM; out PObject): HRESULT; stdcall;
var
hInst: HWND;
lRes: Cardinal;
MSG: Integer;
pDoc: IHTMLDocument2;
ObjectFromLresult: TObjectFromLresult;
begin
hInst := LoadLibrary('Oleacc.dll');
#ObjectFromLresult := GetProcAddress(hInst, 'ObjectFromLresult');
if #ObjectFromLresult <> nil then begin
try
MSG := RegisterWindowMessage('WM_HTML_GETOBJECT');
SendMessageTimeOut(WHandle, MSG, 0, 0, SMTO_ABORTIFHUNG, 1000, lRes);
Result := ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
Result := GetLastError;
if Result = S_OK then
(pDoc.parentWindow as IServiceprovider).QueryService(IWebbrowserApp, IWebbrowser2, IE);
finally
FreeLibrary(hInst);
end;
end;
I used spy++ to look for the chrome frame handle, and I found them.
Wnd := GetForegroundWindow;
WndChild := FindWindowEx(Wnd, 0, 'Chrome_WidgetWin_0', nil);
WndChild := FindWindowEx(WndChild, 0, 'Chrome_RenderWidgetHostHWND', nil);
WndChild := FindWindowEx(WndChild, 0, 'CompositorHostWindowClass', nil);
But it can't catch the result in function called ObjectFromLresult.
ObjectFromLresult(lRes, IHTMLDocument2, 0, pDoc);
The error code I got was 127.
Does it mean chrome browser not support this way to fetch its html document?
If the answer is yes, is there another way to catch it?
thanks a lot.
PS: I have tried to use MSAA tree, but it didn't work too.(Can only fetch the title)
This is not possible, IHtmlDocument2 is interface supported only in IE hosting objects, WebKit engine used in Chrome doesn't support it. You can however use MSAA to access elements, but you need to enable accessibility feature first: http://www.chromium.org/developers/design-documents/accessibility
Or alternatively you can access DOM via remote debugging protocol: https://developers.google.com/chrome-developer-tools/docs/protocol/1.0/index
Related
I am having issues with loading a CSV into a StringGrid. Occasionally, it runs out of memory, but also it seems to have blank columns after each value. I've not really read from a CSV as opposed to output to one, so I took a stock example online and modified it for my needs.
This is what I've currently got:
procedure x.LoadCSVtoGrid(ACSVFile : String; AStringGrid: TStringGrid)
var
LRowIndex, LColIndex: Integer;
LStrLine: string;
LFile: TStringList;
begin
AStringGrid.RowCount := 0;
AStringGrid.ColCount := 0;
if not FileExists(ACSVFile) then
exit;
LFile := TStringList.Create;
try
LFile.LoadFromFile(ACSVFile);
if LFile.Count = 0 then
exit;
AStringGrid.ColCount := Max(AStringGrid.ColCount, WordCount(LFile[0], [',', '"'], '"'));
AStringGrid.RowCount := LFile.Count;
for LRowIndex := 0 to LFile.Count - 1 do
begin
LStrLine := LFile[LRowIndex];
LColIndex := 0;
while LStrLine <> '' do
begin
if Pos('"', LStrLine) = 1 then
begin
Delete(LStrLine, 1, 1);
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos('"', LStrLine) - 1);
Delete(LStrLine, 1, Pos('"', LStrLine));
end
else
begin
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos(',', LStrLine) - 1);
Delete(LStrLine, 1, Pos(',', LStrLine));
end;
Inc(LColIndex);
end;
end;
finally
LFile.Free;
end;
For smaller CSV files, it does fine. I think it's reading up to 250-300 lines before. Some of the files it has to deal with now are 500+.
To be honest, I don't do much handling of the data of the CSV until it's been imported into the StringGrid, but once it's in the StringGrid, it's validated. I've got to make sure that commas within speech marks, ie "text, here", are ignored, as it's part of the value. Again, this appears to handle the reading fine.
Another issue I think I might run into is AStringGrid.RowCount := LFile.Count;, as some of the CSV files have blank lines. If there is a way to deal with this, I am happy to take suggestions.
There are a few versions of CSV files it should be able to read, ie the calculation of column counts and such. Code for WordCount:
function x.WordCount(const S: string; const WordDelims: TSysCharSet; const QuoteChar: Char) : Integer;
var
LInWord: Boolean;
LQuoteOpen: Boolean;
i: Integer;
begin
Result := 0;
LInWord := False;
LQuoteOpen := False;
for i := 1 to Length(S) do
begin
if S[i] in WordDelims then
begin
if not LInWord or LQuoteOpen then
LInWord := False
else
begin
LInWord := True;
Inc(Result);
end;
end
else
begin
if S[i] = QuoteChar then
LQuoteOpen := not LQuoteOpen;
LInWord := True;
end;
end;
if LInWord and (not LQuoteOpen) then
Inc(Result);
I've tried multiple files, for the most part this issue only happens with larger CSV files with more content. I've tried various versions of CSV-to-StringGrid procedures to see if there is something innately wrong with the example I took above. The example works, but only on smaller files.
Let me know if you need more information.
Memory issue
First you create a TStringList and then load it with data
LFile := TStringList.Create;
LFile.LoadFromFile(ACSVFile);
Because you load the whole file into the string list, you need that much of memory, plus equally much to hold the data in the TStringGrid.
Reduce memory requirement by reading the file in chunks of, say, 1000 lines at the time, which you then can throw away after they are moved to the string grid.
OTOH, your "Out of memory" problem might also be caused by the errors in your code. I experienced an "Out of memory" error with my very small test file when run with your unaltered code.
Issues with code
In my tests I used a simple file with a few records and a quoted field in different locations. The file content is:
one,two,"text, including comma",four,five
one,two,three,four,five
"text, including comma",two,three,four,five
one,two,three,four,"text, including comma"
You determine required number of columns in the TStringGrid, by calling the WordCount() function, to which you pass the first string from the string list.
WordCount(const S: string; const WordDelims: TSysCharSet; const QuoteChar: Char) : Integer;
When I pass in the first test string,
'one,two,three,four,five',
WordCount returns correctly 5
Then, control returns to LoadCSVtoGrid(), and after assigning AStringGrid.ColCount and RowCount the for LRowIndex loop starts to fill the grid with data for the current row. Pay attention to the second part, after else:
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos(',', LStrLine) - 1);
Delete(LStrLine, 1, Pos(',', LStrLine));
The Delete() deletes from beginning of LStrLine to Pos(',', LStrLine). This works ok for items "one,", "two,", "three," and "four,", but not for "five" as there is no comma after the last item.
This is the major flaw in the code as it never deletes the last item. Instead, since the loop runs while LString <> '' it just continues incrementing LColIndex
On my machine it stops after a couple of minutes with an out-of-memory error.
Here is my take on WordCount (renamed WordCountNew) function:
function TForm50.WordCountNew(const s: string; const Delimiter: Char;
const QuoteChar: Char): Integer;
var
InWord, InQuote: boolean;
i: integer;
begin
if s = '' then // Just in case we are fed an empty string
Exit(0);
Result := 1; // Init, at least one data item
InWord := False; // Init
InQuote:= False; // Init
for i := 1 to Length(s) do
begin
if s[i] = QuoteChar then // The field is quoted
InQuote := not InQuote; // make note about it
if s[i] = Delimiter then // Delimiter found
begin
if not InQuote then // ... but only count it,
inc(Result); // if not within a quote
end;
end;
end;
Then the LoadCSVtoGrid procedure:
procedure TForm50.LoadCSVtoGrid(ACSVFile: String; AStringGrid: TStringGrid);
var
LRowIndex, LColIndex: Integer;
LStrLine: string;
LFile: TStringList;
CommaPos: integer; // added
begin
AStringGrid.RowCount := 0;
AStringGrid.ColCount := 0;
if not FileExists(ACSVFile) then
exit;
LFile := TStringList.Create;
try
LFile.LoadFromFile(ACSVFile);
if LFile.Count = 0 then
exit;
// When determining column count we should ONLY count the field separator, comma.
// A quote character is not an indication of a new column / field.
// Therefore we remove the array of chars, `[',', '"']` and replace with `','`
// AStringGrid.ColCount := Max(AStringGrid.ColCount, WordCount(LFile[0], [',', '"'], '"'));
AStringGrid.ColCount := Max(AStringGrid.ColCount, WordCountNew(LFile[0], ',', '"'));
AStringGrid.RowCount := LFile.Count;
for LRowIndex := 0 to LFile.Count - 1 do
begin
LStrLine := LFile[LRowIndex];
LColIndex := 0;
while LStrLine <> '' do
begin
if Pos('"', LStrLine) = 1 then
begin
Delete(LStrLine, 1, 1);
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, Pos('"', LStrLine) - 1);
AStringGrid.UpdateControlState;
Delete(LStrLine, 1, Pos('"', LStrLine));
Delete(LStrLine, 1, Pos(',', LStrLine));
end
else
begin
CommaPos := Pos(',', LStrLine);
if CommaPos = 0 then CommaPos := Length(LStrLine)+1;
AStringGrid.Cells[LColIndex, LRowIndex] := Copy(LStrLine, 1, CommaPos-1); //Pos(',', LStrLine) - 1);
AStringGrid.UpdateControlState;
Delete(LStrLine, 1, CommaPos); // Pos(',', LStrLine));
end;
Inc(LColIndex);
end;
end;
finally
LFile.Free;
end;
end;
I added the CommaPos variable, to make it easier to artificially simulate a comma at the end of the string.
With these changes the test file is properly read into the grid.
I'm trying to post some text to an edit box that is on 3rd level on the windows tree.
The following code works ok for notepad (vrr02) but not in another program (Var03).
procedure TEcr01.Button1Click(Sender: TObject);
var Var01, Var02, Var03, vrr01, vrr02: HWND;
MyTxt : string;
begin
Var01 := FindWindow('#32770', nil);
Var02 := FindWindowEx(Var01, 0, '#32770', nil);
Var03 := FindWindowEx(Var01, Var02, 'Edit', nil);
vrr01 := FindWindow('notepad', nil);
vrr02 := FindWindowEx(vrr01, 0, 'edit', nil);
MyTxt := 'This is some text.';
SendMessage(Var03, WM_SETTEXT, 0, integer(MyTxt));
SendMessage(vrr02, WM_SETTEXT, 0, integer(MyTxt));
end;
The following image has in blue the Edit I want to post to but nothing is showing there. What am I doing wrong here?
Thanks.
With your current code you can't be sure if you've got the window handle you want at any of the stages.
"#32770" is standard dialog class, there can be many window of this class at any given time in a user session. You're passing nil for lpWindowName parameter in your FindWindow call, documentation states:
lpWindowName [in, optional]
Type: LPCTSTR
The window name (the window's title). If this parameter is NULL, all window names match.
So there is a probability that you have an entirely different window's handle at Var01 which have the same class but different window title.
Or none at all. That's why you have to check if the function failed or not after every API call. Refer to the function's documentation for how.
Var01 := FindWindow('#32770', 'Object Properties');
Win32Check(Var01 <> 0);
The above call specifies both class name and the window title which as much as guarantees that the function will return the window handle that you want.
Var02 := FindWindowEx(Var01, 0, '#32770', nil);
Win32Check(Var02 <> 0);
The call for Var02 looks alright. But Var03's parent is Var02, so you've got the third call wrong again.
Var03 := FindWindowEx(Var02, 0, 'Edit', nil);
Win32Check(Var03 <> 0);
This will retrieve the first Edit, the hidden one. You must call FindWindowEx again to retrieve the child you want, specify the previous window as the ChildAfter parameter.
Var03 := FindWindowEx(Var02, Var03, 'Edit', nil);
Win32Check(Var03 <> 0);
Also note that SendMessage's fourth parameter is not an integer, always refer to documentation.
All in all:
Var01 := FindWindow('#32770', 'Object Properties');
Win32Check(Var01 <> 0);
Var02 := FindWindowEx(Var01, 0, '#32770', nil);
Win32Check(Var02 <> 0);
Var03 := FindWindowEx(Var02, 0, 'Edit', nil);
Win32Check(Var03 <> 0);
Var03 := FindWindowEx(Var02, Var03, 'Edit', nil);
Win32Check(Var03 <> 0);
MyTxt := 'This is some text.';
SendMessage(Var03, WM_SETTEXT, 0, LPARAM(MyTxt));
SendMessage(vrr02, WM_SETTEXT, 0, LPARAM(MyTxt));
I need support for "friendly name hyperlink" in TRichEdit and all solutions I have found are based on autoURLs (EM_AUTOURLDETECT) which works by detecting strings entered by user that start with www (or http).
But I want to place links on strings that does not start with www. Example: 'Download'.
You need to do the following:
send the RichEdit an EM_SETEVENTMASK message to enable the ENM_LINK flag. Do this once after the RichEdit has been created, and then do it again every time the RichEdit receives a CM_RECREATEWND message.
select the desired text you want to turn into a link. You can use the RichEdit's SelStart and SelLength properties, or send the RichEdit an EM_SETSEL or EM_EXSETSEL message. Either way, then send the RichEdit an EM_SETCHARFORMAT message with a CHARFORMAT2 struct to enable the CFE_LINK effect on the selected text.
subclass the RichEdit's WindowProc property to handle CN_NOTIFY(EN_LINK) and CM_RECREATEWND messages. When EN_LINK is received, you can use ShellExecute/Ex() to launch the desired URL.
For example:
unit Unit1;
interface
uses
Winapi.Windows, Winapi.Messages, System.SysUtils, System.Variants, System.Classes, Vcl.Graphics,
Vcl.Controls, Vcl.Forms, Vcl.Dialogs, Vcl.StdCtrls, Vcl.ComCtrls;
type
TForm1 = class(TForm)
RichEdit1: TRichEdit;
Button1: TButton;
procedure FormCreate(Sender: TObject);
procedure Button1Click(Sender: TObject);
private
{ Private declarations }
PrevRichEditWndProc: TWndMethod;
procedure InsertHyperLink(const HyperlinkText: string);
procedure SetRichEditMasks;
procedure RichEditWndProc(var Message: TMessage);
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.dfm}
uses
Winapi.RichEdit, Winapi.ShellAPI;
procedure TForm1.FormCreate(Sender: TObject);
begin
PrevRichEditWndProc := RichEdit1.WindowProc;
RichEdit1.WindowProc := RichEditWndProc;
SetRichEditMasks;
RichEdit1.Text := 'Would you like to Download Now?';
RichEdit1.SelStart := 18;
RichEdit1.SelLength := 12;
InsertHyperLink('Download Now');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
InsertHyperLink('Another Link');
end;
procedure TForm1.InsertHyperLink(const HyperlinkText: string);
var
Fmt: CHARFORMAT2;
StartPos: Integer;
begin
StartPos := RichEdit1.SelStart;
RichEdit1.SelText := HyperlinkText;
RichEdit1.SelStart := StartPos;
RichEdit1.SelLength := Length(HyperlinkText);
FillChar(Fmt, SizeOf(Fmt), 0);
Fmt.cbSize := SizeOf(Fmt);
Fmt.dwMask := CFM_LINK;
Fmt.dwEffects := CFE_LINK;
SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(#Fmt));
RichEdit1.SelStart := StartPos + Length(HyperlinkText);
RichEdit1.SelLength := 0;
end;
procedure TForm1.SetRichEditMasks;
var
Mask: DWORD;
begin
Mask := SendMessage(RichEdit1.Handle, EM_GETEVENTMASK, 0, 0);
SendMessage(RichEdit1.Handle, EM_SETEVENTMASK, 0, Mask or ENM_LINK);
SendMessage(RichEdit1.Handle, EM_AUTOURLDETECT, 1, 0);
end;
procedure TForm1.RichEditWndProc(var Message: TMessage);
type
PENLINK = ^ENLINK;
var
tr: TEXTRANGE;
str: string;
p: PENLINK;
begin
PrevRichEditWndProc(Message);
case Message.Msg of
CN_NOTIFY: begin
if TWMNotify(Message).NMHdr.code = EN_LINK then
begin
P := PENLINK(Message.LParam);
if p.msg = WM_LBUTTONUP then
begin
SetLength(str, p.chrg.cpMax - p.chrg.cpMin);
tr.chrg := p.chrg;
tr.lpstrText := PChar(str);
SendMessage(RichEdit1.Handle, EM_GETTEXTRANGE, 0, LPARAM(#tr));
if str = 'Download Now' then
begin
ShellExecute(Handle, nil, 'http://www.SomeSite.com/download', nil, nil, SW_SHOWDEFAULT);
end
else if str = 'Another Link' then
begin
// do something else
end;
end;
end;
end;
CM_RECREATEWND: begin
SetRichEditMasks;
end;
end;
end;
end.
Update: Per MSDN:
RichEdit Friendly Name Hyperlinks
In RichEdit, the hyperlink field entity is represented by character formatting effects, as contrasted to delimiters which are used to structure math objects. As such, these hyperlinks cannot be nested, although in RichEdit 5.0 and later they can be adjacent to one another. The whole hyperlink has the character formatting effects of CFE_LINK and CFE_LINKPROTECTED, while autoURLs only have the CFE_LINK attribute. The CFE_LINKPROTECTED is included for the former so that the autoURL scanner skips over friendly name links. The instruction part, i.e., the URL, has the CFE_HIDDEN attribute as well, since it’s not supposed to be displayed. The URL itself is enclosed in ASCII double quotes and preceded by the string “HYPERLINK “. Since CFE_HIDDEN plays an integral role in friendly name hyperlinks, it cannot be used in the name.
For example, in WordPad, which uses RichEdit, a hyperlink with the name MSN would have the plain text
HYPERLINK “http://www.msn.com”MSN
The whole link would have CFE_LINK and CFE_LINKPROTECTED character formatting attributes and all but the MSN would have the CFE_HIDDEN attribute.
This can be simulated easily in code:
procedure TForm1.FormCreate(Sender: TObject);
begin
...
RichEdit1.Text := 'Would you like to Download Now?';
RichEdit1.SelStart := 18;
RichEdit1.SelLength := 12;
InsertHyperLink('Download Now', 'http://www.SomeSite.com/downloads');
end;
procedure TForm1.Button1Click(Sender: TObject);
begin
InsertHyperLink('A Text Link');
end;
procedure TForm1.InsertHyperLink(const HyperlinkText: string; const HyperlinkURL: string = '');
var
HyperlinkPrefix, FullHyperlink: string;
Fmt: CHARFORMAT2;
StartPos: Integer;
begin
if HyperlinkURL <> '' then
begin
HyperlinkPrefix := Format('HYPERLINK "%s"', [HyperlinkURL]);
FullHyperlink := HyperlinkPrefix + HyperlinkText;
end else begin
FullHyperlink := HyperlinkText;
end;
StartPos := RichEdit1.SelStart;
RichEdit1.SelText := FullHyperlink;
RichEdit1.SelStart := StartPos;
RichEdit1.SelLength := Length(FullHyperlink);
FillChar(Fmt, SizeOf(Fmt), 0);
Fmt.cbSize := SizeOf(Fmt);
Fmt.dwMask := CFM_LINK;
Fmt.dwEffects := CFE_LINK;
if HyperlinkURL <> '' then
begin
// per MSDN: "RichEdit doesn’t allow the CFE_LINKPROTECTED attribute to be
// set directly by programs. Maybe it will allow it someday after enough
// testing is completed to ensure that things cannot go awry"...
//
{
Fmt.dwMask := Fmt.dwMask or CFM_LINKPROTECTED;
Fmt.dwEffects := Fmt.dwEffects or CFE_LINKPROTECTED;
}
end;
SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(#Fmt));
if HyperlinkURL <> '' then
begin
RichEdit1.SelStart := StartPos;
RichEdit1.SelLength := Length(HyperlinkPrefix);
FillChar(Fmt, SizeOf(Fmt), 0);
Fmt.cbSize := SizeOf(Fmt);
Fmt.dwMask := CFM_HIDDEN;
Fmt.dwEffects := CFE_HIDDEN;
SendMessage(RichEdit1.Handle, EM_SETCHARFORMAT, SCF_SELECTION, LPARAM(#Fmt));
end;
RichEdit1.SelStart := StartPos + Length(FullHyperlink);
RichEdit1.SelLength := 0;
end;
And then handled in the EN_LINK notification by parsing the clicked hyperlink text:
uses
..., System.StrUtils;
...
SendMessage(RichEdit1.Handle, EM_GETTEXTRANGE, 0, LPARAM(#tr));
// Per MSDN: "The ENLINK notification structure contains a CHARRANGE with
// the start and end character positions of the actual URL (IRI, file path
// name, email address, etc.) that typically appears in a browser URL
// window. This doesn’t include the “HYPERLINK ” string nor the quotes in
// the hidden part. For the MSN link above, it identifies only the
// http://www.msn.com characters in the backing store."
//
// However, without the CFM_LINKPROTECTED flag, the CHARRANGE will report
// the positions of the entire "HYPERLINK ..." string instead, so just strip
// off what is not needed...
//
if StartsText('HYPERLINK "', str) then
begin
Delete(str, 1, 11);
Delete(str, Pos('"', str), MaxInt);
end;
if (str is a URL) then begin
ShellExecute(Handle, nil, PChar(str), nil, nil, SW_SHOWDEFAULT);
end
else begin
// do something else
end;
I want to open a local HTML file in the default browser.
For example:
Default Browser is Mozilla Firefox.
The file to be opened: C:\My Custom Path\New Folder\AFile.htm
Please note the path has spaces. Depending on conditions I want to append an Id at the end of the URL.
Final URL is C:\My Custom Path\New Folder\AFile.htm#12345
If I open the browser manually, and paste the URL "C:\My Custom Path\New Folder\AFile.htm#12345".
It works fine. Unable to find the best way to do this through code.
ShellExecute/Ex() won't work directly using "open" verb with the anchor (#) in the URL. even if you use file:// protocol the anchor will be omitted.
The best way is to get the path for the default browser, you can use FindExecutable, and then execute it and pass the URL as a parameter.
uses
ShellAPI;
procedure TForm1.Button1Click(Sender: TObject);
var
Res: HINST;
Buffer: array[0..MAX_PATH] of Char;
SEInfo: TShellExecuteInfo;
HtmlFile, Anchor: string;
begin
HtmlFile := 'd:\1 - Copy.html';
Anchor := '#123';
FillChar(Buffer, SizeOf(Buffer), 0);
Res := FindExecutable(PChar(HtmlFile), nil, Buffer);
if Res <= 32 then
raise Exception.Create(SysErrorMessage(Res));
FillChar(SEInfo, SizeOf(SEInfo), 0);
SEInfo.cbSize := SizeOf(SEInfo);
with SEInfo do
begin
lpFile := PChar(string(Buffer));
lpParameters := PChar(Format('"file:///%s"', [HtmlFile + Anchor]));
nShow := SW_SHOWNORMAL;
fMask := SEE_MASK_FLAG_NO_UI; // Do not display an error message box if an error occurs.
end;
if not ShellExecuteEx(#SEInfo) then
RaiseLastOSError;
end;
EDIT: Looks like the file:/// URI scheme is important in cases where the URL includes query string parameters (e.g file.html?param=foo#bar) or else the ? is escaped to %3F (tested in Chrome)
Unfortunately you can't do it only with ShellExecute.
But there is some hack.
For example you want to open url like this:
C:\Users\User\Desktop\Some sitename with spaces.htm with the anchor #myAnchor
To make ShellExecute open file:
vS := 'file:///C:\Users\User\Desktop\Some sitename with spaces.htm#MyAnchor';
ShellExecute(0, 'OPEN', PChar(vS), '', '', SW_SHOWNORMAL);
It's Important to use "file:///" in the beginning, but ShellExecute open this page without anchor.
To open with the anchor you can dynamically create html file with content like this:
<html>
<meta http-equiv=Refresh content="0; url=file:///C:\Users\User\Desktop\Some sitename with spaces.htm#MyAnchor">
<body></body>
</html>
And open this dynamic file with ShellExecute.
Hope it helps.
One can also create a process launching CMD.EXE with the following parameters :
'/C start '+Url
Quick and dirty, but it should work OK
I ended up doing this. I get the default browser, and used the CreateProcess API to launch the browser with my custom URL.
Notice, I add the 'file:///' in the beginning and also surround the string with double quotes.
function GetDefaultBrowser(): String;
var
ExecName: array[0..MAX_PATH] of Char;
FHandle: THandle;
MyPath: String;
begin
Result := '';
MyPath := small.GetTempPath;
FHandle := System.SysUtils.FileCreate(MyPath + 'AFile.htm');
if FHandle <> INVALID_HANDLE_VALUE then
begin
FillChar(ExecName, Length(ExecName), #0);
if FindExecutable('AFile.htm', PChar(MyPath), ExecName) > 32 then
Result := ExecName;
System.SysUtils.FileClose(FHandle);
System.SysUtils.DeleteFile(MyPath + 'AFile.htm');
end;
end;
procedure LaunchHTMLPage(NumberToAppend : string);
var
Start: TStartupInfo;
Process: TProcessInformation;
FileNameString, AppPathAndName, AppPathOnly: string;
begin
AppPathAndName := GetDefaultBrowser ;
//Break the AppPathAndName and get the path name to use later
//I am adding double quotes in the path name to escape the spaces and the '#'
FileNameString := AnsiQuotedStr('file:///' + Application.HelpFile + '#' + NumberToAppend, '"');
AppPathAndName := AppPathAndName + ' ' + FileNameString;
FillChar(Start, SizeOf(StartUpInfo), #0);
FillChar(Process, SizeOf(TProcessInformation), #0);
CreateProcess(nil, PChar(AppPathAndName), nil, nil, false, CREATE_NEW_PROCESS_GROUP + NORMAL_PRIORITY_CLASS, nil, PChar(AppPathOnly), StartUpInfo, ProcessInfo);
end;
i think this is better way:
function OpenHtmlFile(FileAdr :string):Boolean;
var
vTempFile :string;
vData :TStrings;
begin
Result:= False;
vTempFile:= GetTempFolder + '_tmphtmlrunfile.html';
vData:= TStringList.Create;
vData.Text:= '<html><head><meta http-equiv="refresh" content="0;URL=''file:///' + FileAdr + '''">';
try
try
vData.SaveToFile(vTempFile, TEncoding.UTF8);
finally
vData.Free;
end;
ShellExecute(Handle,
'open',
PChar(vTempFile),
nil,
nil,
SW_SHOWNORMAL);
Result:= True;
except
end;
end;
Here is my implementation that supports all common web browsers and Microsoft Edge (Windows Store App).
It refers to the issues with queries (?) and fragments (#) in the URI and the issue with file:/// protocol in combination with the Edge browser.
(I use it for HTML output of "Flare" software, that's why the "help" in the naming of variables)
// AHelpFileName := 'C:\temp\Default.htm';
// AHelpID := '123';
procedure TSomeClass.OpenHelp(const AHelpFileName, AHelpID: string);
var
URL: string;
BrowserPath, FileName, Parameters: PWideChar;
begin
URL := Format('file:///%s', [AHelpFileName]);
if AHelpID <> '' then
URL := Format('%s#cshid=%s', [URL, AHelpID])
URL := StringReplace(URL, '\', '/', [rfReplaceAll]);
URL := StringReplace(URL, ' ', '%20', [rfReplaceAll]);
BrowserPath := StrAlloc(MAX_PATH);
Parameters := nil;
if FindExecutable(PWideChar(AHelpFileName), nil, BrowserPath) > 32 then
begin
Parameters := PWideChar(URL);
if SameText(ExtractFileName(BrowserPath), 'LaunchWinApp.exe') then
// Default browser is a Windows Store App (and most likely it is Edge)
FileName := 'shell:AppsFolder\Microsoft.MicrosoftEdge_8wekyb3d8bbwe!MicrosoftEdge'
else
// IE, Chrome, Firefox, Opera, Vivaldi, ...
FileName := BrowserPath;
end
else
FileName := PWideChar(URL);
ShellExecute(0, nil, FileName, Parameters, nil, SW_SHOWNORMAL);
end;
I am using TWebBrowser as editor GUI for users. I want to be able to insert web controls into the document. A simple example would be a check box. (I can elaborate why if needed). I have all this working when I first assemble the HTML document (with its STYLE and SCRIPTS sections) and then pass it en-block to the TWebBrowser. But now I want to be able to insert my elements into an existing document.
I have this code, below, but it is causing and OLE error (see in comments in code):
procedure THTMLTemplateDocument.EnsureStylesInWebDOM;
var StyleBlock : IHTMLElement;
StyleText: string;
begin
StyleBlock := FWebBrowser.GetDocStyle;
if not assigned(StyleBlock) then
raise Exception.Create('Unable to access <STYLE> block in web document');
StyleText := FCumulativeStyleCodes.Text;
StyleBlock.InnerText := StyleText; <--- generates "OLE ERROR 800A0258"
end;
The called functions from the above code are as follows:
function THtmlObj.GetDocStyle: IHTMLElement;
//Return pointer to <STYLE> block, creating this if it was not already present.
var
Document: IHTMLDocument2; // IHTMLDocument2 interface of Doc
Elements: IHTMLElementCollection; // all tags in document body
AElement: IHTMLElement; // a tag in document body
Style, Head: IHTMLElement;
I: Integer; // loops thru Elements in document body
begin
Result := nil;
if not Supports(Doc, IHTMLDocument2, Document) then
raise Exception.Create('Invalid HTML document');
Elements := Document.all;
for I := 0 to Pred(Elements.length) do begin
AElement := Elements.item(I, EmptyParam) as IHTMLElement;
if UpperCase(AElement.tagName) <> 'STYLE' then continue;
result := AElement;
break;
end;
if not assigned(Result) then begin
Head := GetDocHead;
if assigned(Head) then begin
Style := Document.CreateElement('STYLE');
(Head as IHTMLDOMNode).AppendChild(Style as IHTMLDOMNode);
Result := Style;
end;
end;
end;
and
function THtmlObj.GetDocHead: IHTMLElement;
//Return pointer to <HEAD> block, creating this if it was not already present.
var
Document: IHTMLDocument2; // IHTMLDocument2 interface of Doc
Elements: IHTMLElementCollection; // all tags in document body
AElement: IHTMLElement; // a tag in document body
Body: IHTMLElement2; // document body element
Head: IHTMLElement;
I: Integer; // loops thru Elements in document body
begin
Result := nil;
if not Supports(Doc, IHTMLDocument2, Document) then
raise Exception.Create('Invalid HTML document');
if not Supports(Document.body, IHTMLElement2, Body) then
raise Exception.Create('Can''t find <body> element');
Elements := Document.all;
for I := 0 to Pred(Elements.length) do begin
AElement := Elements.item(I, EmptyParam) as IHTMLElement;
if UpperCase(AElement.tagName) <> 'HEAD' then continue;
Result := AElement;
break;
end;
if not assigned(Result) then begin
Head := Document.CreateElement('HEAD');
(Body as IHTMLDOMNode).insertBefore(Head as IHTMLDOMNode, Body as IHTMLDOMNode);
//now look for it again
Elements := Document.all;
for I := 0 to Pred(Elements.length) do begin
AElement := Elements.item(I, EmptyParam) as IHTMLElement;
if UpperCase(AElement.tagName) <> 'HEAD' then continue;
Result := AElement;
break;
end;
end;
end;
When I run this, StyleText =
'.selected {'#$D#$A' font-weight : bold;'#$D#$A' //background-color : yellow;'#$D#$A'}'#$D#$A'.unselected {'#$D#$A' font-weight : normal;'#$D#$A' //background-color : white;'#$D#$A'}'#$D#$A#$D#$A
But I tried making StyleText to be something simple like 'hello', and it still crashed.
A Google search for "OLE ERROR 800A0258" reveals several other people who have had similar problems, such as here and here -- this later user seems to indicate he fixed the problem by using .OuterHTML, but I tried this with similar error generated. This thread seems to indicate the .InnerText is read only. But in the interface declaration (see below), it seems to have a method for setting (i.e. not read-only).
// *********************************************************************//
// Interface: IHTMLElement
// Flags: (4416) Dual OleAutomation Dispatchable
// GUID: {3050F1FF-98B5-11CF-BB82-00AA00BDCE0B}
// *********************************************************************//
IHTMLElement = interface(IDispatch)
['{3050F1FF-98B5-11CF-BB82-00AA00BDCE0B}']
...
procedure Set_innerHTML(const p: WideString); safecall;
function Get_innerHTML: WideString; safecall;
procedure Set_innerText(const p: WideString); safecall;
function Get_innerText: WideString; safecall;
procedure Set_outerHTML(const p: WideString); safecall;
function Get_outerHTML: WideString; safecall;
procedure Set_outerText(const p: WideString); safecall;
function Get_outerText: WideString; safecall;
...
property innerHTML: WideString read Get_innerHTML write Set_innerHTML;
property innerText: WideString read Get_innerText write Set_innerText;
property outerHTML: WideString read Get_outerHTML write Set_outerHTML;
property outerText: WideString read Get_outerText write Set_outerText;
...
end;
Can anyone help be figure out how to set up STYLES in the <STYLE> section of an existing HTML document in a TWebBrowser?
If you have valid IHTMLDocument2, then you can call its createStyleSheet(). It will return IHTMLStyleSheet instance. You can use its cssText property to set style.
Make sure you take account of document's character encoding.
Based on guidance from #Zamrony P. Juhara, I came up with the following code. I am posting in case it can help anyone else in the future.
procedure THtmlObj.AddStylesToExistingStyleSheet(StyleSheet: IHTMLStyleSheet; SelectorSL, CSSLineSL : TStringList);
//NOTE: There must be a 1:1 correlation between SelectorSL and CSSLineSL
// The first SL will contain the selector text
// the second SL will contain all the CSS in one line (divided by ";"'s)
var
SLIdx, RuleIdx, p: integer;
SelectorText, CSSText, OneCSSEntry : string;
begin
if not assigned(StyleSheet) then begin
raise Exception.Create('Invalid StyleSheet');
end;
for SLIdx := 0 to SelectorSL.Count - 1 do begin
SelectorText := SelectorSL.Strings[SLIdx];
if SlIdx > (CSSLineSL.Count - 1) then break;
CSSText := CSSLineSL.Strings[SLIdx];
while CSSText <> '' do begin
p := Pos(';', CSSText);
if p > 0 then begin
OneCSSEntry := MidStr(CSSText, 1, p);
CSSText := MidStr(CSSText, p+1, Length(CSSText));
end else begin
OneCSSEntry := CSSText;
CSSText := '';
end;
RuleIdx := StyleSheet.Rules.length;
StyleSheet.addRule(SelectorText, OneCSSEntry, RuleIdx);
end;
end;
end;
function THtmlObj.AddStyles(SelectorSL, CSSLineSL : TStringList) : IHTMLStyleSheet;
//NOTE: There must be a 1:1 correlation between SelectorSL and CSSLineSL
// The first SL will contain the selector text
// the second SL will contain all the CSS in one line (divided by ";"'s)
var
Document: IHTMLDocument2; // IHTMLDocument2 interface of Doc
StyleSheets: IHTMLStyleSheetsCollection; // document's style sheets
StyleSheet: IHTMLStyleSheet; // reference to a style sheet
OVStyleSheet: OleVariant; // variant ref to style sheet
Idx: integer;
begin
Result := nil;
if not Supports(Doc, IHTMLDocument2, Document) then begin
raise Exception.Create('Invalid HTML document');
end;
StyleSheets := Document.styleSheets;
Idx := Document.StyleSheets.length;
OVStyleSheet := Document.createStyleSheet('',Idx);
if not VarSupports(OVStyleSheet, IHTMLStyleSheet, StyleSheet) then begin
raise Exception.Create('Unable to create valid style sheet');
end;
Result := StyleSheet;
AddStylesToExistingStyleSheet(StyleSheet, SelectorSL, CSSLineSL);
end; //AddStyles