main.pas

从网页上下载图片的程序

    edit1.Enabled := True;
    Edit2.Enabled := True;
  end
  else
  begin
    Edit1.Enabled := False;
    Edit2.Enabled := False;
  end;
end;

procedure TMainForm.Edit1Change(Sender: TObject);
begin
  if StrToInt(Edit1.Text) > StrToInt(Edit2.Text) then
  begin
    MessageBox(0, '最小的文件大小不能够比最大的大', '错误', MB_OK +
      MB_ICONSTOP);
    Edit1.Text := '0';
  end;
end;

procedure TMainForm.Edit2Change(Sender: TObject);
begin
  if StrToInt(Edit1.Text) > StrToInt(Edit2.Text) then
  begin
    MessageBox(0, '最小的文件大小不能够比最大的大', '错误', MB_OK +
      MB_ICONSTOP);
    Edit2.Text := IntToStr(StrToInt(Edit1.Text) + 10);
  end;
end;

procedure TMainForm.Edit1KeyPress(Sender: TObject; var Key: Char);
begin
  if (key in ['0'..'9'] = false) and (word(key) <> vk_back) and (key <> #13)
    then
  begin
    {---   键入内容控制          ---}
    key := #0;
  end;
end;

procedure TMainForm.Edit2KeyPress(Sender: TObject; var Key: Char);
begin
  if (key in ['0'..'9'] = false) and (word(key) <> vk_back) and (key <> #13)
    then
  begin
    {---   键入内容控制          ---}
    key := #0;
  end;
end;

procedure TMainForm.ComboBox1KeyPress(Sender: TObject; var Key: Char);
begin
  if key = #13 then
    Button4.Click;
end;

procedure TMainForm.Button2Click(Sender: TObject);
var
  I: Integer;
begin
  for i := 0 to CheckListBox1.Count - 1 do
  begin
    if CheckListBox1.Checked[i] = True then
      if CheckListBox1.Items.Count <> 0 then
        {---   判断是否图片的数目为零  ---}
      begin
        if UBBLabel.Checked then
          Memo1.Lines.Add('[IMG]' + CheckListBox1.Items.Strings[i] + '[/IMG]')
        else
          Memo1.Lines.Add(CheckListBox1.Items.Strings[i])
      end;
  end;
end;

procedure TMainForm.WebBrowser1DownloadBegin(Sender: TObject);
begin
  Button1.Enabled := False;
  StatusBar1.SimpleText := '正在下载该页面，请耐心等待……';
end;

procedure TMainForm.WebBrowser1DownloadComplete(Sender: TObject);

begin
  Button1.Enabled := True;
  StatusBar1.SimpleText := '下载该页面完成，请单击分析取得页面的图片';
end;

procedure TMainForm.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  WebBrowser1 := nil;
end;

procedure TMainForm.Button4Click(Sender: TObject);
var
  i, j, AddressNum: integer;
  Addressreg: TRegIniFile;
  CanSave: boolean;
  AddressList: TStringLIst;
begin
  WebBrowser1.Navigate(Combobox1.Text);
  Addressreg := TRegIniFile.Create('');
  CanSave := True;
  with Addressreg do
  try
    begin
      RootKey := HKEY_LOCAL_MACHINE;
      openkey('software\网页图片地址拷贝器\', true);
      AddressNum := ReadInteger('GetPicAddress', 'AddressNum', 0);
      for i := 0 to AddressNum do
      begin
        if Trim(Combobox1.text) = ReadString('GetPicAddress', IntToStr(I), '')
          then
          CanSave := False;
        if AddressNum < 1 then
          CanSave := True;
      end;
      if (AddressNum < 10) and CanSave and (Trim(Combobox1.text) <> '') then
      begin
        {---   少于10条记录允许保存  ---}
        writestring('GetPicAddress', IntToStr(AddressNum + 1),
          Trim(Combobox1.text));
        WriteInteger('GetPicAddress', 'AddressNum', AddressNum + 1);
        free;
      end;
      if (AddressNum >= 10) and CanSave and (Trim(Combobox1.text) <> '') then
      begin
        {---   多于10条记录删除最后的一个  ---}
        AddressList := TstringList.Create;
        for j := 1 to 10 do
          AddressList.Add(ReadString('GetPicAddress', IntToStr(j), ''));
        {---   取得当前注册表中所有的键值  ---}
        for j := 0 to 8 do
          AddressList.Strings[j] := AddressList.Strings[j + 1];
        AddressList.Strings[9] := Trim(Combobox1.text);
        for j := 1 to 10 do
        begin
          writestring('GetPicAddress', IntToStr(j), AddressList.Strings[j - 1]);
          WriteInteger('GetPicAddress', 'AddressNum', j);
        end;
        free;
      end;
    end;
  except
    begin
      MessageBox(0, '写入注册表出现异常错误！放弃保存', '严重错误', MB_OK +
        MB_ICONSTOP);
      free;
    end;
  end;
  combobox1.OnDropDown(self);
end;

procedure TMainForm.PageControl1Change(Sender: TObject);
begin
  if PageControl1.TabIndex = 2 then
  begin
   MessageBox(0, '    网页图片转贴器' + #13#10#13#10 + 
     '    我是一个懒人，还有一点时间就离开学校了，于是经常上网看一些图片，发'
     + #13#10 + 
     '现有的时候从一个论坛转到另外一个论坛很麻烦，总是要手动的找到该图片的地' 
     + #13#10 + 
     '址，然后一个一个链接贴过去。因此萌发念头，写了这个小程序。代码很简单，' 
     + #13#10 + '功能我个人认为还是很实用的。' + #13#10#13#10 + 
     '    把一个网站的地址粘贴到地址栏中，然后分析出来想要的图片文件，得到想' 
     + #13#10 + '要的地址。然后就可以取得该图片的地址。' + #13#10#13#10 + 
     '    该程序对于喜欢转贴大量图片的人来说应该是一个比较好的助手。刚写出来，' 
     + #13#10 + 
     '很多的地方很不完善，希望大家多提宝贵意见条件有限，只是在windows2000 ＋ ' 
     + #13#10 + 'IE5 下通过，有问题可以给我发信联系。欢迎提出，多谢！' + 
     #13#10#13#10 + '    [e-mail]' + #13#10#13#10 + 
     '    版本修正发布一般在 http://www.yaguo.com/~cm991' + #13#10#13#10 + 
     '    也可以在smth.org找到我，[e-mail]' + #13#10#13#10 + 
     '    版本历史：ver 0.0.0.1 2003.6.23' + #13#10 + 
     '     1 、初步设想开发，实现基本功能' + #13#10#13#10#13#10 + 
     '    ver 0.0.0.2 2003.6.24' + #13#10 + '    1 、实现了图片的批量保存功能' 
     + #13#10 + '    2 、图片地址添加有重复修正' + #13#10 + 
     '    3 、已用地址显示重复问题和保存问题' + #13#10 + 
     '    4 、对于iFrame、Frame 的网页支持取图', '网页图片转贴器……', MB_OK + 
     MB_ICONINFORMATION);
     
    PageControl1.TabIndex := 0;
  end;
end;

procedure TMainForm.ComboBox1DropDown(Sender: TObject);
var
  Addressreg: TRegIniFile;
  I: integer;
begin
  combobox1.Clear;
  Addressreg := TRegIniFile.Create('');
  with Addressreg do
  begin
    try
      RootKey := HKEY_LOCAL_MACHINE;
      if keyexists('software\网页图片地址拷贝器\GetPicAddress') then
      begin
        openkey('software\网页图片地址拷贝器', false);
        for i := 1 to ReadInteger('GetPicAddress', 'AddressNum', 1) do
        begin
          combobox1.Items.Add(ReadString('GetPicAddress', IntToStr(0 + I), ''));
        end;
        closekey;
      end;
    except
      begin
        MessageBox(0, '读取注册表出现异常错误，使用系统默认连接', '严重错误',
          MB_OK + MB_ICONSTOP);
      end;
      free;
    end;
  end;

end;

procedure TMainForm.Panel6Click(Sender: TObject);
begin
  //showmessage(WebBrowser1.LocationURL);
end;

procedure TMainForm.Button5Click(Sender: TObject);
var
  I, j: Integer;
  dir: widestring;
  tmp: TStringList;
  SaveFileName: string;
begin
  tmp := TStringList.Create;
  tmp.Delimiter := '/';
  {---   为取得页面的最后一个路径名的文件名称  ---}
  if SelectDir.ShowModal = mrOk then
    {---   调出路径选择对话框 uses Qdialogs  ---}
  begin
    dir := SelectDir.Label3.Caption;
    for i := 0 to CheckListBox1.Count - 1 do
    begin
      if CheckListBox1.Checked[i] = True then
      begin
        tmp.DelimitedText := CheckListBox1.Items.Strings[i];
        for j := 0 to tmp.Count - 1 do
          SaveFileName := tmp.Strings[j];
        {---   得到文件名            ---}
        StatusBar1.SimpleText := '正在保存所选中的文件，请稍候……';
        if not DownloadFile(CheckListBox1.Items.Strings[i], dir + '\' +
          SaveFileName) then
          MessageBox(0, Pchar('下载' + CheckListBox1.Items.Strings[i] +
            '不成功'),
            '网页图片转贴器……', MB_OK + MB_ICONSTOP);

      end;
    end;
  end;
end;

procedure TMainForm.Timer1Timer(Sender: TObject);
var
  I, j: Integer;
  tmp: TStringList;
begin

  {---   Uses Clipbrd          ---}
  tmp := TStringList.Create;
  tmp.Delimiter := '/';
  ClipBoard.Open;
  for i := 0 to combobox1.Items.Count - 1 do
  begin
    if combobox1.Items.Strings[i] = Clipboard.AsText then
    begin
      ClipBoard.Close;
      exit;
    end;
  end;
  try
    if ClipBoard.HasFormat(CF_TEXT) and CheckBox2.Checked then
    begin
      tmp.DelimitedText := Clipboard.AsText;
      if tmp.Strings[0] = 'http:' then
        {---   如果监视到剪贴板的内容为网址的话。那么就下载该页面  ---}
      begin
        Combobox1.Text := Clipboard.AsText;
        Button4.Click;
      end;
    end;
  finally
    ClipBoard.Close;
  end;

end;

procedure TMainForm.WebBrowser1NewWindow2(Sender: TObject;
  var ppDisp: IDispatch; var Cancel: WordBool);
begin
  cancel := true;
  {---   取消新的窗口打开      ---}
end;

end.