main.pas

从网页上下载图片的程序

{***********************************************************}
{                                                           }
{       网页图片转贴器                                      }
{                                                           }
{       windows2000＋Delphi 7                               }
{                                                           }
{       [e-mail]                                      }
{                                                           }
{       2003-6-24 14:13:11                                  }
{                                                           }
{       版权所有 (C) 2002, 2003                             }
{                                                           }
{***********************************************************}
unit main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, OleCtrls, mshtml, ExtCtrls, CheckLst, Clipbrd,
  ComCtrls, SHDocVw, Registry, urlmon;

type
  TMainForm = class(TForm)
    PageControl1: TPageControl;
    TabSheet1: TTabSheet;
    TabSheet2: TTabSheet;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel3: TPanel;
    Panel4: TPanel;
    Panel5: TPanel;
    Memo1: TMemo;
    Panel6: TPanel;
    Button1: TButton;
    Button2: TButton;
    Button3: TButton;
    WebBrowser1: TWebBrowser;
    ComboBox1: TComboBox;
    TabSheet3: TTabSheet;
    Panel7: TPanel;
    Panel8: TPanel;
    Panel9: TPanel;
    Panel10: TPanel;
    UBBLabel: TCheckBox;
    Panel11: TPanel;
    Panel12: TPanel;
    Edit1: TEdit;
    Edit2: TEdit;
    Label1: TLabel;
    Label2: TLabel;
    CheckBox1: TCheckBox;
    Label3: TLabel;
    Label4: TLabel;
    Label5: TLabel;
    StatusBar1: TStatusBar;
    Button4: TButton;
    Button5: TButton;
    Panel13: TPanel;
    Panel14: TPanel;
    Panel15: TPanel;
    WebBrowser2: TWebBrowser;
    Panel16: TPanel;
    CheckListBox1: TCheckListBox;
    CheckBox2: TCheckBox;
    Timer1: TTimer;
    procedure Button1Click(Sender: TObject);
    procedure CheckListBox1Click(Sender: TObject);
    procedure CheckListBox1DblClick(Sender: TObject);
    procedure Button3Click(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure CheckBox1Click(Sender: TObject);
    procedure Edit1Change(Sender: TObject);
    procedure Edit2Change(Sender: TObject);
    procedure Edit1KeyPress(Sender: TObject; var Key: Char);
    procedure Edit2KeyPress(Sender: TObject; var Key: Char);
    procedure ComboBox1KeyPress(Sender: TObject; var Key: Char);
    procedure Button2Click(Sender: TObject);
    procedure WebBrowser1DownloadBegin(Sender: TObject);
    procedure WebBrowser1DownloadComplete(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure Button4Click(Sender: TObject);
    procedure PageControl1Change(Sender: TObject);
    procedure ComboBox1DropDown(Sender: TObject);
    procedure Panel6Click(Sender: TObject);
    procedure Button5Click(Sender: TObject);
    procedure Timer1Timer(Sender: TObject);
    procedure WebBrowser1NewWindow2(Sender: TObject; var ppDisp: IDispatch;
      var Cancel: WordBool);

  private
    { Private declarations }
  public
    function DownloadFile(Source, Dest: string): Boolean;
    {---   文件下载用函数        ---}
    procedure ADDList(herfList: string);
    {---   保证加入不重复的连接  ---}
    { Public declarations }
  end;

var
  MainForm: TMainForm;

implementation

uses SelectDirUnit;

{$R *.dfm}

function TMainForm.DownloadFile(Source, Dest: string): Boolean;
begin
  //uses urlmon
  try
    Result := UrlDownloadToFile(nil, PChar(source), PChar(Dest), 0, nil) = 0;
  except
    Result := False;
  end;
end;

procedure TMainForm.ADDList(herfList: string);
var
  i: integer;
  cansave: boolean;
begin
  cansave := True;
  if CheckListBox1.Count <> 0 then
  begin
    for i := 0 to CheckListBox1.Count - 1 do
    begin
      if herfList = CheckListBox1.Items.Strings[i] then
      begin
        cansave := False;
        exit;
      end
      else
        Cansave := True;
    end;
  end;
  if cansave then
    CheckListBox1.Items.Add(herfList);
end;

procedure TMainForm.Button1Click(Sender: TObject);
var
  doc, doc1: IHTMLDocument2;
  all: IHTMLElementCollection;
  //all: IHTMLImageElementFactory;
  len, i, j, k: integer;
  HtmlFrame: ihtmlframescollection2;
  HtmlWin, oneframe: Ihtmlwindow2;
  spdisp: idispatch;
  vv, vi, VJ, item: OleVariant;
  img: IHTMLImgElement;
  b: IHTMLElement;
begin
  //if not webbrowser1.Busy then
    {---   判断是否网页load完成了  ---}
  //begin
  CheckListBox1.Clear;
  {---   清除原来的内容        ---}
  //;
  doc := WebBrowser1.Document as IHTMLDocument2;
  if Doc <> nil then
  begin
    HtmlFrame := doc.Get_frames;
    showmessage(IntToStr(HtmlFrame.length));
    if HtmlFrame.length > 1 then
    begin
      for j := 0 to HtmlFrame.length - 1 do
      begin
        Application.ProcessMessages;
        vj := j;
        spDisp := HtmlFrame.item(vj);
        if SUCCEEDED(spDisp.QueryInterface(IHTMLWindow2, HtmlWin)) then
        begin
          //   Memo2.Lines.Add(HtmlWin.name); //写上frame的name
          if SUCCEEDED(HtmlWin.document.QueryInterface(IHTMLDocument2, Doc))
            then
          begin
            doc1 := HtmlWin.document as IHTMLDocument2;
            all := doc1.images;

            len := all.length;
            for i := 0 to len - 1 do
            begin
              item := all.item(i, varempty);
              //all.
              //EmpryParam亦可
              b := all.item(i, 0) as IHTMLElement;
              img := b as IHTMLImgElement;
              //showmessage(img.fileSize);
              if CheckBox1.Checked then
              begin
                {---   如果大小控制选中，那么进行控制  ---}
                if (StrToFloat(img.fileSize) / 1024 >= StrToFloat(Edit1.Text))
                  and
                  (StrToFloat(img.fileSize) / 1024 <= StrToFloat(Edit2.Text))
                    then
                  ADDList(item.href);
                {---   保证加入不重复的连接  ---}
              end
              else
              begin
                ADDList(item.href);
              end;
            end;
            //vj := Doc.Get_all.item(0, 0);
            //Memo2.Lines.Add(vj.innerhtml); //这里是frame的网页代码啦
          end;

        end;
      end;
    end;
    all := doc.images;
    len := all.length;
    for i := 0 to len - 1 do
    begin
      item := all.item(i, varempty);
      //all.
      //EmpryParam亦可
      b := all.item(i, 0) as IHTMLElement;
      img := b as IHTMLImgElement;
      //showmessage(img.fileSize);
      if CheckBox1.Checked then
      begin
        {---   如果大小控制选中，那么进行控制  ---}
        if (StrToFloat(img.fileSize) / 1024 >= StrToFloat(Edit1.Text))
          and
          (StrToFloat(img.fileSize) / 1024 <= StrToFloat(Edit2.Text)) then
          ADDList(item.href);
        {---   保证加入不重复的连接  ---}
      end
      else
      begin
        ADDList(item.href);
      end;
    end;

    {---   取得所有的图片对象    ---}
  end;
end;

procedure TMainForm.CheckListBox1Click(Sender: TObject);
begin
  //CheckListBox1.ItemIndex
  if CheckListBox1.Items.Count <> 0 then
    {---   判断是否图片的数目为零  ---}
  begin
    webbrowser2.Navigate(CheckListBox1.Items.Strings[CheckListBox1.ItemIndex]);
  end
  else
  begin
    showmessage('没有显示的图片在该页面上面');
  end;
end;

procedure TMainForm.CheckListBox1DblClick(Sender: TObject);
begin
  if CheckListBox1.Items.Count <> 0 then
    {---   判断是否图片的数目为零  ---}
  begin
    if UBBLabel.Checked then
      Memo1.Lines.Add('[IMG]' +
        CheckListBox1.Items.Strings[CheckListBox1.ItemIndex] + '[/IMG]')
    else
      Memo1.Lines.Add(CheckListBox1.Items.Strings[CheckListBox1.ItemIndex])
  end;
end;

procedure TMainForm.Button3Click(Sender: TObject);
begin
  Memo1.SelectAll;
  Memo1.CopyToClipboard;
end;

procedure TMainForm.FormShow(Sender: TObject);

begin
  webbrowser1.Navigate(ComboBox1.text);
  Application.Title := '网页图片地址拷贝器';
  MainForm.Caption := '网页图片地址拷贝器';

  //Edit1.Text := '0';
  //Edit2.Text := '1000'
    {---   设置初始化文件大小    ---}
  CheckListBox1.ShowHint := True;
  CheckListBox1.Hint := '双击可以添加该图片地址到文本编辑框';

  Combobox1.ShowHint := True;
  Combobox1.Hint := '键入地址之后，单击回车键可以打开该页面';
  combobox1.Clear;

  PageControl1.TabIndex := 0;

end;

procedure TMainForm.CheckBox1Click(Sender: TObject);
begin
  if checkBox1.Checked then
  begin