Delphi 用程序实现自动的html操作

unit Unit1;
 
interface
 
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, OleCtrls, SHDocVw, mshtml, StdCtrls, ExtCtrls;
 
const  
    CMySearchName: string = 'test';
 
type
  TForm1 = class(TForm)
    WebBrowser1: TWebBrowser;
    ButtonSearch: TButton;
    ButtonRefresh: TButton;
    TimerRefresh: TTimer;
    TimerSearch: TTimer;
    ButtonIsFind: TButton;
    TimerFind: TTimer;
    TimerDial: TTimer;
    ButtonDial: TButton;
    procedure ButtonRefreshClick(Sender: TObject);
    procedure ButtonSearchClick(Sender: TObject);
    procedure WebBrowser1NavigateComplete2(ASender: TObject;
      const pDisp: IDispatch; var URL: OleVariant);
    procedure WebBrowser1NavigateError(ASender: TObject; const pDisp: IDispatch;
      var URL, Frame, StatusCode: OleVariant; var Cancel: WordBool);
    procedure TimerRefreshTimer(Sender: TObject);
    procedure TimerSearchTimer(Sender: TObject);
    procedure ButtonIsFindClick(Sender: TObject);
    procedure TimerFindTimer(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure ButtonDialClick(Sender: TObject);
    procedure TimerDialTimer(Sender: TObject);
  private
    FIsNavSuccess: Boolean;
    FHasExcScript: Boolean;
    FHasSearch: Boolean;
    FHasFind: Boolean;
  public
    { Public declarations }
  end;
 
var
  Form1: TForm1;
 
implementation
 
{$R *.dfm}
 
procedure ExecuteScript(aWebBrowser: TWebBrowser; XScript: WideString; language: WideString = 'javascript');
var
  HTDoc: IHTMLDocument2;
begin
  HTDoc := (aWebBrowser.Document as IHTMLDocument2);
  if (HTDoc <> nil) then
  begin
      if HTDoc.parentWindow <> nil then
        HTDoc.parentWindow.ExecScript(XScript, Olevariant(language)) ;
  end;
end;
 
procedure DoIdle(XMsSec: Cardinal);
var
  ElapsedTime: Cardinal;
begin
  ElapsedTime := 0;
  while ElapsedTime < XMsSec do
  begin
    Application.ProcessMessages;
    Sleep(10);
    Inc(ElapsedTime, 10);
  end;
end;
 
procedure MoniClick(X, Y: Integer);
var
  LCount: Integer;
begin
  LCount := 0;
  while not SetCursorPos(X, Y) do
  begin
    Inc(LCount);
    if LCount > 100 then
      Exit;
  end;
  
  DoIdle(100);
  mouse_event(MOUSEEVENTF_LEFTDOWN, 0,0,0,GetMessageExtraInfo());
  DoIdle(100);
  mouse_event(MOUSEEVENTF_LEFTUP, 0,0,0,GetMessageExtraInfo());
end;
 
 
function GetBodyAll(XDoc: IDispatch): IHTMLElementCollection;
var
  LDoc: HTMLDocument;
  LBody: HTMLBody;
begin
  Result := nil;
    
  LDoc := XDoc as HTMLDocument;
  if LDoc = nil then
    Exit;
  LBody := LDoc.body as HTMLBody;
  if LBody = nil then
    Exit;
 
  Result := LBody.all as IHTMLElementCollection;
end;
 
function GetBodyElement(const ABodyAll: IHTMLElementCollection; const AnElementName: string): IHTMLElement;
var
  LName: OleVariant;
  LIndex: OleVariant;
begin
  Result := nil;
 
  LName := AnElementName;
  Result := ABodyAll.item(LName, LIndex) as IHTMLElement;
end;
 
function GetBodyElementStrValue(XBodyAll: IHTMLElementCollection; const AnItemName: string; var RetStr: string): Boolean;
var
  LElem: IHTMLElement;
begin
  Result := False;
 
  LElem := GetBodyElement(XBodyAll, AnItemName);
  if LElem <> nil then
  begin
    try
      RetStr := Trim(LElem.getAttribute('value', 0));
      Result := True;
    except
    end;
  end;
end;
 
function GetIFrameBodyAll(XDoc: IDispatch; XFrameIndex: Integer): IHTMLElementCollection;
var
  LIframeCollection:IHTMLElementCollection;
  L1Iframe:IWebBrowser;
  LLen: Integer;
 
  LDoc: HTMLDocument;
  LBody: HTMLBody;
begin
  Result := nil;
 
  LIframeCollection:=GetBodyAll(XDoc).tags('iframe') as IHTMLElementCollection;
  LLen := LIframeCollection.length;
  if (LLen > 0) and (XFrameIndex >= 0) and (XFrameIndex < LLen) then
  begin
    L1Iframe:= LIframeCollection.item(XFrameIndex, varEmpty) as IWebBrowser;
    LDoc := L1Iframe.document as HTMLDocument;
    if LDoc = nil then
      Exit;
    LBody := LDoc.body as HTMLBody;
    if LBody = nil then
      Exit;
 
    Result := LBody.all as IHTMLElementCollection;
  end;
end;
 
function SetBodyElementStrValue(XBodyAll: IHTMLElementCollection; const AnItemName: string; const XValueStr: string): Boolean;
var
  LElem: IHTMLElement;
  LValue: OleVariant;
begin
  Result := False;
 
  LElem := GetBodyElement(XBodyAll, AnItemName);
  if LElem <> nil then
  begin
    try
      LValue := XValueStr;
      LElem.setAttribute('value', LValue, 0);
      Result := True;
    except
    end;
  end;
end;
 
procedure TForm1.ButtonSearchClick(Sender: TObject);
const
  CNameSearchName = 'J_SearchKeyword';
  CNameBtn = 'J_SerachList';
var
  LOldValue: string;
  LBodyAll: IHTMLElementCollection;
  LEdit: IHTMLInputElement;
  LBtn: IHTMLElement;
begin
  inherited;
 
  if not FIsNavSuccess then
    Exit;
 
  // 不模拟实现了   t1.focus(); t1.blur();
  //MoniClick(Left + WebBrowser1.Left + 200, Top + WebBrowser1.Top + WebBrowser1.Height + 15);
 
  //LBodyAll := GetIFrameBodyAll(WebBrowser1.Document, 0);
  LBodyAll := GetBodyAll(WebBrowser1.Document);
  if LBodyAll = nil then
    Exit;
 
  if FHasExcScript then
  begin
    LBtn := GetBodyElement(LBodyAll, CNameBtn);
    if LBtn = nil then
      Exit;
 
    LBtn.click;
 
    FHasSearch := True;
    TimerFind.Enabled := True;
 
    Exit;
  end;
 
  if not GetBodyElementStrValue(LBodyAll, CNameSearchName, LOldValue) then
  begin
    Exit;
  end;
  if LOldValue <> CMySearchName then
  begin
    if not SetBodyElementStrValue(LBodyAll, CNameSearchName, CMySearchName) then
      Exit;
 
    LEdit := GetBodyElement(LBodyAll, CNameSearchName) as IHTMLInputElement;
    if LEdit = nil then
      Exit;
 
    ExecuteScript(WebBrowser1, ' var t1 = document.getElementById("J_SearchKeyword");  t1.focus(); t1.blur();');
    FHasExcScript := True;
  end;
end;
 
procedure TForm1.FormShow(Sender: TObject);
begin
  TimerRefreshTimer(nil);
end;
 
procedure TForm1.ButtonDialClick(Sender: TObject);
var
  LParent: HWND;
  LHandle: HWND;
  LRect: TRect;
begin
  //  class:
  //  btn: tSkMainForm -> TConversationForm -> TNonLiveCallToolbar
 
  LHandle := FindWindow('tSkMainForm', nil);
  if LHandle = 0 then
    Exit;
 
  if not ShowWindow(LHandle,SW_SHOWNORMAL) then
    Exit;
  if not SetForegroundWindow(LHandle) then
    Exit;
 
  DoIdle(100);
 
  LParent := LHandle;
  LHandle := FindWindowEx(LParent, 0, 'TConversationForm', nil);
  if LHandle = 0 then
    Exit;
 
  LParent := LHandle;
  LHandle := FindWindowEx(LParent, 0, 'TNonLiveCallToolbar', nil);
  if LHandle = 0 then
    Exit;
  
  if not GetWindowRect(LHandle, LRect) then
    Exit;
 
  MoniClick(LRect.Left + 50, LRect.Top + 22);
 
  TimerDial.Enabled := False;
end;
 
procedure TForm1.ButtonIsFindClick(Sender: TObject);
 
  function IsFindIndex(XAllChild: IHTMLElementCollection; XIndex: Integer): Boolean;
  var
    LItem0: IHTMLElement;
    LIndex0: OleVariant;
    LName: OleVariant;
    LFindText: WideString;
    LSearchName: WideString;
  begin
    Result := False;
    LIndex0 := XIndex;
    // activity-item clearfix
    LItem0 := XAllChild.item(LName, LIndex0) as IHTMLElement;
    if LItem0 = nil then
      Exit;
 
    LFindText := LItem0.innerHTML;
    LSearchName := CMySearchName;
    if Pos(LSearchName, LFindText) > 0 then
    begin
      Result := True;
    end;
  end;
  
 
const
  CNameActiveListName = 'J_ActivityList';
var
  LBodyAll: IHTMLElementCollection;
  LList: IHTMLElement;
  LChild: IHTMLElementCollection;
  I: Integer;
begin
  inherited;
 
  if not FHasSearch then
    Exit;
 
  LBodyAll := GetBodyAll(WebBrowser1.Document);
  if LBodyAll = nil then
    Exit;
 
  LList := GetBodyElement(LBodyAll, CNameActiveListName);
  if LList = nil then
    Exit;
 
  LChild := LList.children as IHTMLElementCollection;
  if LChild = nil then
    Exit;
 
  if LChild.length > 0 then
  begin
    for I := 0 to LChild.length - 1 do
    begin
      if IsFindIndex(LChild, I) then
      begin
        TimerFind.Enabled := False;
        TimerRefresh.Enabled := False;
        TimerSearch.Enabled := False;
 
        FHasFind := True;
        TimerDial.Enabled := True;
 
        Break;
      end;
    end;
  end;
end;
 
procedure TForm1.ButtonRefreshClick(Sender: TObject);
begin
  FIsNavSuccess := False;
  FHasExcScript := False;
  FHasSearch := False;
  FHasFind := False;
 
  TimerSearch.Enabled := False;
  TimerFind.Enabled := False;
  TimerDial.Enabled := False;
  
  WebBrowser1.Navigate('http://yingxiao.taobao.com/list.htm');
end;
 
procedure TForm1.TimerDialTimer(Sender: TObject);
begin
  if not TimerDial.Enabled then
    Exit;
  if not FHasFind then
    Exit;
  ButtonDial.Click;
end;
 
procedure TForm1.TimerFindTimer(Sender: TObject);
begin
  if not TimerFind.Enabled then
    Exit;
  ButtonIsFind.Click;
end;
 
procedure TForm1.TimerRefreshTimer(Sender: TObject);
begin
  if not TimerRefresh.Enabled then
    Exit;
  ButtonRefresh.Click;
end;
 
procedure TForm1.TimerSearchTimer(Sender: TObject);
begin
  if not TimerSearch.Enabled then
    Exit;
  ButtonSearch.Click;
end;
 
procedure TForm1.WebBrowser1NavigateComplete2(ASender: TObject;
  const pDisp: IDispatch; var URL: OleVariant);
begin
  FIsNavSuccess := True;
  TimerSearch.Enabled := True;
end;
 
procedure TForm1.WebBrowser1NavigateError(ASender: TObject;
  const pDisp: IDispatch; var URL, Frame, StatusCode: OleVariant;
  var Cancel: WordBool);
begin
  FIsNavSuccess := False;
end;
 
end.
 
 
 
 
 
object Form1: TForm1
  Left = 0
  Top = 0
  BorderStyle = bsDialog
  Caption = 'Form1'
  ClientHeight = 552
  ClientWidth = 930
  Color = clBtnFace
  Font.Charset = DEFAULT_CHARSET
  Font.Color = clWindowText
  Font.Height = -11
  Font.Name = 'Tahoma'
  Font.Style = []
  OldCreateOrder = False
  OnShow = FormShow
  DesignSize = (
    930
    552)
  PixelsPerInch = 96
  TextHeight = 13
  object WebBrowser1: TWebBrowser
    AlignWithMargins = True
    Left = 0
    Top = 0
    Width = 930
    Height = 452
    Margins.Left = 0
    Margins.Top = 0
    Margins.Right = 0
    Margins.Bottom = 100
    Align = alClient
    TabOrder = 0
    OnNavigateComplete2 = WebBrowser1NavigateComplete2
    OnNavigateError = WebBrowser1NavigateError
    ExplicitLeft = 3
    ExplicitTop = 3
    ExplicitWidth = 637
    ExplicitHeight = 301
    ControlData = {
      4C0000001E600000B72E00000000000000000000000000000000000000000000
      000000004C000000000000000000000001000000E0D057007335CF11AE690800
      2B2E126208000000000000004C0000000114020000000000C000000000000046
      8000000000000000000000000000000000000000000000000000000000000000
      00000000000000000100000000000000000000000000000000000000}
  end
  object ButtonSearch: TButton
    Left = 288
    Top = 506
    Width = 89
    Height = 25
    Anchors = [akLeft, akBottom]
    Caption = 'ButtonSearch'
    TabOrder = 1
    Visible = False
    OnClick = ButtonSearchClick
  end
  object ButtonRefresh: TButton
    Left = 144
    Top = 506
    Width = 97
    Height = 25
    Anchors = [akLeft, akBottom]
    Caption = 'ButtonRefresh'
    TabOrder = 2
    Visible = False
    OnClick = ButtonRefreshClick
  end
  object ButtonIsFind: TButton
    Left = 424
    Top = 506
    Width = 89
    Height = 25
    Caption = 'ButtonIsFind'
    TabOrder = 3
    Visible = False
    OnClick = ButtonIsFindClick
  end
  object ButtonDial: TButton
    Left = 560
    Top = 506
    Width = 75
    Height = 25
    Caption = 'ButtonDial'
    TabOrder = 4
    Visible = False
    OnClick = ButtonDialClick
  end
  object TimerRefresh: TTimer
    Interval = 50000
    OnTimer = TimerRefreshTimer
    Left = 8
    Top = 464
  end
  object TimerSearch: TTimer
    Enabled = False
    Interval = 10000
    OnTimer = TimerSearchTimer
    Left = 40
    Top = 464
  end
  object TimerFind: TTimer
    Enabled = False
    OnTimer = TimerFindTimer
    Left = 72
    Top = 464
  end
  object TimerDial: TTimer
    Enabled = False
    Interval = 5000
    OnTimer = TimerDialTimer
    Left = 112
    Top = 464
  end
end 
 
 
————————————————
 
原文链接：https://blog.csdn.net/xiuzhentianting/article/details/48377259
posted @   txiuq  阅读(224)  评论(0)  编辑  收藏  举报
相关博文：
·  给 TWebBrowser.Document 定义事件
·  Delphi TWebBrowser编程简述
·  EverythingSdk
·  Delphi 通过WebBrowser调用JS方法
·  Delphi生成JSON
阅读排行：
· TypeScript + Deepseek 打造卜卦网站：技术与玄学的结合
· Manus的开源复刻OpenManus初探
· AI 智能体引爆开源社区「GitHub 热点速览」
· 三行代码完成国际化适配，妙~啊~
· .NET Core 中如何实现缓存的预热？
点击右上角即可分享
微信分享提示
SQL AI 助手