Client Application 과 Web 과의 환상적인 비빔밥을 만들 수 있게 해주는 TWebbrowser ....
한번 빠져 봅시다 (대부분 Delphi .about 에서 빌림)
unit Unit1;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, OleCtrls, SHDocVw;
type
TForm1 = class(TForm)
WebBrowser1: TWebBrowser;
btnNaverTest: TButton;
btnURLGo: TButton;
Edit1: TEdit;
Memo1: TMemo;
btnViewSource: TButton;
btnAppendStr2Web: TButton;
Memo2: TMemo;
btnStringLoad2Web: TButton;
btnBrowserHTMLSaveFile: TButton;
btnRunJScript: TButton;
procedure btnNaverTestClick(Sender: TObject);
procedure WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
procedure FormCreate(Sender: TObject);
procedure WebBrowser1BeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
procedure WebBrowser1CommandStateChange(Sender: TObject;
Command: Integer; Enable: WordBool);
procedure WebBrowser1DownloadBegin(Sender: TObject);
procedure WebBrowser1DownloadComplete(Sender: TObject);
procedure btnURLGoClick(Sender: TObject);
procedure WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch;
var Cancel: WordBool);
procedure btnViewSourceClick(Sender: TObject);
procedure btnAppendStr2WebClick(Sender: TObject);
procedure btnStringLoad2WebClick(Sender: TObject);
procedure btnBrowserHTMLSaveFileClick(Sender: TObject);
procedure FormDestroy(Sender: TObject);
procedure btnRunJScriptClick(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
procedure Logx(AMsg:String);
procedure WebBrowser1BeforeNavigate2Ex(ASender: TObject; const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData, Headers: OleVariant; var Cancel: WordBool) ;
end;
var
Form1: TForm1;
MouseHook: HHOOK; { for Mouse Hook }
implementation
{$R *.dfm}
uses mshtml, ActiveX, ShellAPI ;
//uses MSHTML_TLB, SHDocVw;
procedure ExecuteScript(doc: IHTMLDocument2; script: string; language: string) ;
begin
if doc <> nil then
begin
if doc.parentWindow <> nil then
doc.parentWindow.ExecScript(script, Olevariant(language)) ;
end;
end;
{ for disable webbrowser context menu }
function MouseProc(nCode: Integer; wParam, lParam: Longint): LongInt; stdcall;
var
classbuf: array[0..255] of Char;
const
ie = 'Internet Explorer_Server';
begin
case nCode < 0 of
True:
Result := CallNextHookEx(MouseHook, nCode, wParam, lParam) ;
False:
case wParam of
WM_RBUTTONDOWN, WM_RBUTTONUP:
begin
GetClassName(PMOUSEHOOKSTRUCT(lParam)^.HWND, classbuf, SizeOf(classbuf)) ;
if lstrcmp(@classbuf[0], @ie[1]) = 0 then
Result := HC_SKIP
else
Result := CallNextHookEx(MouseHook, nCode, wParam, lParam) ;
end
else
begin
Result := CallNextHookEx(MouseHook, nCode, wParam, lParam) ;
end;
end; //case wParam
end; //case nCode
end; (*MouseProc*)
procedure WB_SaveAs_HTML(WB : TWebBrowser; const FileName : string) ;
var
PersistStream: IPersistStreamInit;
Stream: IStream;
FileStream: TFileStream;
begin
if not Assigned(WB.Document) then
begin
ShowMessage('Document not loaded!') ;
Exit;
end;
PersistStream := WB.Document as IPersistStreamInit;
FileStream := TFileStream.Create(FileName, fmCreate) ;
try
Stream := TStreamAdapter.Create(FileStream, soReference) as IStream;
if Failed(PersistStream.Save(Stream, True)) then ShowMessage('SaveAs HTML fail!') ;
finally
FileStream.Free;
end;
end; (* WB_SaveAs_HTML *)
procedure WBLoadHTML(WebBrowser: TWebBrowser; HTMLCode: string) ;
var
sl: TStringList;
ms: TMemoryStream;
begin
WebBrowser.Navigate('about:blank') ;
while WebBrowser.ReadyState < READYSTATE_INTERACTIVE do
Application.ProcessMessages;
if Assigned(WebBrowser.Document) then
begin
sl := TStringList.Create;
try
ms := TMemoryStream.Create;
try
sl.Text := HTMLCode;
sl.SaveToStream(ms) ;
ms.Seek(0, 0) ;
(WebBrowser.Document as IPersistStreamInit).Load(TStreamAdapter.Create(ms)) ;
finally
ms.Free;
end;
finally
sl.Free;
end;
end;
end;
procedure AppendToWB(WB: TWebBrowser; const html: widestring) ;
var
Range: IHTMLTxtRange;
begin
Range := ((WB.Document AS IHTMLDocument2).body AS IHTMLBodyElement).createTextRange;
Range.Collapse(False) ;
Range.PasteHTML(html) ;
end;
{
UploadFilesHttpPost(
WebBrowser1,
'http://validator.w3.org/check', // upload server url
[],
[],
['uploaded_file'],
['C:\blank.htm'] ); // upload local file
}
procedure UploadFilesHttpPost(const wb:TWebBrowser; const URLstring: string; names, values, nFiles, vFiles: array of string) ;
var
strData, n, v, boundary: string;
URL: OleVariant;
Flags: OleVariant;
PostData: OleVariant;
Headers: OleVariant;
idx: Integer;
ms: TMemoryStream;
ss: TStringStream;
begin
if Length(names) <> Length(values) then
raise Exception.Create('UploadFilesHttpPost: Names and Values must have the same length.') ;
if Length(nFiles) <> Length(vFiles) then
raise Exception.Create('UploadFilesHttpPost: FileNames and FileValues must have the same length.') ;
URL := 'about:blank';
Flags := NavNoHistory or NavNoReadFromCache or NavNoWriteToCache or NavAllowAutosearch;
wb.Navigate2(URL, Flags) ;
while wb.ReadyState < READYSTATE_INTERACTIVE do Application.ProcessMessages;
// anything random that WILL NOT occur in the data.
boundary := '---------------------------123456789';
strData := '';
for idx := Low(names) to High(names) do
begin
n := names[idx];
v := values[idx];
strData := strData + '--' + boundary + #13#10 + 'Content-Disposition: form-data; name="' + n + '"' + #13#10#13#10 + v + #13#10;
end;
for idx := Low(nFiles) to High(nFiles) do
begin
n := nFiles[idx];
v := vFiles[idx];
strData := strData + '--' + boundary + #13#10 + 'Content-Disposition: form-data; name="' + n + '"; filename="' + v + '"' + #13#10;
if v = '' then
begin
strData := strData + 'Content-Transfer-Encoding: binary' + #13#10#13#10;
end
else
begin
if (CompareText(ExtractFileExt(v), '.JPG') = 0) or (CompareText(ExtractFileExt(v), '.JPEG') = 0) then
begin
strData := strData + 'Content-Type: image/pjpeg'#13#10#13#10;
end
else if (CompareText(ExtractFileExt(v), '.PNG') = 0) then
begin
strData := strData + 'Content-Type: image/x-png'#13#10#13#10;
end
else if (CompareText(ExtractFileExt(v), '.PDF') = 0) then
begin
strData := strData + 'Content-Type: application/pdf'#13#10#13#10;
end
else if (CompareText(ExtractFileExt(v), '.HTML') = 0) then
begin
end;
strData := strData + 'Content-Type: text/html'#13#10#13#10;
ms := TMemoryStream.Create;
try
ms.LoadFromFile(v) ;
ss := TStringStream.Create('') ;
try
ss.CopyFrom(ms, ms.Size) ;
strData := strData + ss.DataString + #13#10;
finally
ss.Free;
end;
finally
ms.Free;
end;
end;
strData := strData + '--' + boundary + '--'#13#10; // FOOTER
end;
strData := strData + #0;
{2. you must convert a string into variant array of bytes and every character from string is a value in array}
PostData := VarArrayCreate([0, Length(strData) - 1], varByte) ;
{ copy the ordinal value of the character into the PostData array}
for idx := 1 to Length(strData) do PostData[idx-1] := Ord(strData[idx]) ;
{3. prepare headers which will be sent to remote web-server}
Headers := 'Content-Type: multipart/form-data; boundary=' + boundary + #13#10;
{4. you must navigate to the URL with your script and send as parameters your array with POST-data and headers}
URL := URLstring;
wb.Navigate2(URL, Flags, EmptyParam, PostData, Headers) ;
while wb.ReadyState < READYSTATE_INTERACTIVE do Application.ProcessMessages;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
MouseHook := SetWindowsHookEx(WH_MOUSE, MouseProc, 0, GetCurrentThreadId()) ;
Edit1.Text := 'http://www.daum.net';
Memo1.Lines.Text := '';
Memo1.ScrollBars := ssBoth;
Memo2.Lines.Text := '<html><body><h1>mulder is king !!!</h1></body></html>';
Memo2.ScrollBars := ssBoth;
end;
procedure TForm1.FormDestroy(Sender: TObject);
begin
if MouseHook <> 0 then UnHookWindowsHookEx(MouseHook) ;
end;
procedure TForm1.btnNaverTestClick(Sender: TObject);
begin
WebBrowser1.Navigate('http://nid.naver.com/login/login.pw.nhn?url=http%3A%2F%2Fwww.naver.com&postDataKey=&svctype=0');
end;
procedure TForm1.WebBrowser1DocumentComplete(Sender: TObject;
const pDisp: IDispatch; var URL: OleVariant);
var
tags: OleVariant;
i: Integer;
loID,loPW: String;
begin
loID:='abcd'; // 사용자 아이디입력
loPW:='pass'; // 사용자 비밀번호 입력
tags := WebBrowser1.OleObject.Document.Body.getElementsByTagName('INPUT');
if WebBrowser1.ReadyState = READYSTATE_COMPLETE then begin
for i := 0 to tags.Length - 1 do
begin
if (tags.Item(i).NAME = 'id') and (tags.item(i).id='id') then
begin
tags.Item(i).value := loID; // 네이버 사용자 ID 입력폼에 삽입
end;
if (tags.Item(i).NAME = 'pw') and (tags.item(i).id='pw') then
begin
tags.Item(i).value := loPW; // // 네이버 사용자 비밀번호 입력폼에 삽입
end;
end;
end;
end;
procedure TForm1.Logx(AMsg:String);
begin
Memo1.Lines.Add(AMsg);
end;
procedure TForm1.WebBrowser1BeforeNavigate2(Sender: TObject;
const pDisp: IDispatch; var URL, Flags, TargetFrameName, PostData,
Headers: OleVariant; var Cancel: WordBool);
begin
Logx ('WebBrowser1BeforeNavigate2:' + URL);
WebBrowser1BeforeNavigate2Ex (Sender, pDisp, URL, Flags, TargetFrameName,
PostData, Headers, Cancel);
end;
procedure TForm1.WebBrowser1CommandStateChange(Sender: TObject;
Command: Integer; Enable: WordBool);
begin
Logx ('WebBrowser1CommandStateChange:' + IntToStr(Command));
end;
procedure TForm1.WebBrowser1DownloadBegin(Sender: TObject);
begin
Logx ('WebBrowser1DownloadBegin:');
end;
procedure TForm1.WebBrowser1DownloadComplete(Sender: TObject);
begin
Logx ('WebBrowser1DownloadComplete:');
end;
procedure TForm1.btnURLGoClick(Sender: TObject);
begin
WebBrowser1.Navigate(Edit1.Text);
end;
procedure TForm1.WebBrowser1NewWindow2(Sender: TObject;
var ppDisp: IDispatch; var Cancel: WordBool);
begin
Logx ('WebBrowser1NewWindow2:');
cancel:=false;
ppDisp:=Form1.WebBrowser1.Application;
end;
procedure TForm1.WebBrowser1BeforeNavigate2Ex(ASender: TObject;
const pDisp: IDispatch;
var URL, Flags, TargetFrameName, PostData, Headers: OleVariant;
var Cancel: WordBool) ;
function OleVariantToMemoryStream(OV: OleVariant): TMemoryStream;
var
Data: PByteArray;
Size: integer;
begin
Result := TMemoryStream.Create;
try
Size := VarArrayHighBound (OV, 1) - VarArrayLowBound(OV, 1) + 1;
Data := VarArrayLock(OV) ;
try
Result.Position := 0;
Result.WriteBuffer(Data^, Size) ;
finally
VarArrayUnlock(OV) ;
end;
except
Result.Free;
Result := nil;
end;
end;
var
ms: TMemoryStream;
ss: TStringStream;
begin
ss := TStringStream.Create('') ;
try
if Length(PostData) > 0 then
begin
ms := OleVariantToMemoryStream(PostData) ;
ms.Position := 0;
ss.CopyFrom(ms, ms.size) ;
ss.Position := 0;
ShowMessage('HEADER:' + Headers + #13#10#13#10 + ss.DataString) ;
end;
finally
ss.Free;
end;
end;
procedure TForm1.btnViewSourceClick(Sender: TObject);
var
iall : IHTMLElement;
begin
if Assigned(WebBrowser1.Document) then
begin
iall := (WebBrowser1.Document AS IHTMLDocument2).body;
while iall.parentElement <> nil do
begin
iall := iall.parentElement;
end;
Logx( iall.outerHTML );
end;
end;
procedure TForm1.btnAppendStr2WebClick(Sender: TObject);
var
s: string;
begin
s:= '<a href="http://delphi.about.com">go to About Delphi Programming</a>';
AppendToWB(WebBrowser1,s) ;
end;
procedure TForm1.btnStringLoad2WebClick(Sender: TObject);
begin
WBLoadHTML (Webbrowser1, Memo2.Lines.Text);
end;
procedure TForm1.btnBrowserHTMLSaveFileClick(Sender: TObject);
var
filename : String;
begin
filename := 'c:\testweb.html';
WB_SaveAs_HTML (Webbrowser1, filename);
//ShellExecute(Handle, Operation, FileName, Params, Folder, ShowCmd)
ShellExecute(Form1.Handle, nil, 'c:\windows\notepad.exe', PChar(filename), nil, SW_SHOWNORMAL);
end;
procedure TForm1.btnRunJScriptClick(Sender: TObject);
var
script : string;
begin
script := 'var elemMain = document.getElementById("main") ; if (elemMain != null) { alert(elemMain.tagName) ; } else { alert("has no main"); }';
ExecuteScript(WebBrowser1.Document as IHTMLDocument2, script, 'javascript')
end;
end.