u_main.pas

软件功能：下载一个网站上所有的彩铃！ 铃声下载完后

  end;

  function ReceiveLine: string;
  var
    C: Char;
    RetLen: Integer;
  begin
    Result := '';
    while Socket <> INVALID_SOCKET do
    begin
      RetLen := recv(Socket, C, 1, 0);
      if (RetLen <= 0) or (RetLen = SOCKET_ERROR) then
        break;
      Add(Result, @C, 1);
      if Pos(CRLF, Result) > 0 then break;
    end;
  end;

  function SendCommand(const Command: string): string;
  var
    P: PChar;
    Data: string;
  begin
    Result := '';
    P := PChar(Command);
    send(Socket, P^, Length(Command), 0);
    while WaitForSocket(5) do
    begin
      Data := ReceiveLine;
      if (Data = '') or (Data = CRLF) then
        break else
        Add(Result, PChar(Data), Length(Data));
    end;
  end;

  procedure InitSocket(const AHost: string);
  var
    Addr: TSockAddrIn;
    Data: TWSAData;
    HostEnt: PHostEnt;
    Timeout: Integer;
  begin
    Winsock.WSAStartup($0101, Data);
    Socket := WinSock.socket(PF_INET, SOCK_STREAM, IPPROTO_IP);
    if Socket = INVALID_SOCKET then
      raise Exception.Create(SysErrorMessage(GetLastError));
    Timeout := 1000;
    WinSock.setsockopt(Socket, SOL_SOCKET, SO_RCVTIMEO, @Timeout, SizeOf(TimeOut));
    HostEnt := gethostbyname(PChar(AHost));
    FillChar(Addr.sin_addr, SizeOf(Addr.sin_addr), 0);
    Addr.sin_family := PF_INET;
    if HostEnt <> nil then
      Move(HostEnt^.h_addr^[0], Addr.sin_addr.S_addr, HostEnt^.h_length)
    else
      raise Exception.CreateFmt('主机没找到: %s', [AHost]);
    Addr.sin_port := htons(80);
    if connect(Socket, Addr, SizeOf(Addr)) <> 0 then
      raise Exception.Create(SysErrorMessage(GetLastError));
  end;

  procedure UnInitSocket;
  begin
    if Socket <> INVALID_SOCKET then
      closesocket(Socket);
    WSACleanup;
  end;

var
  Data, FileName, Host: string;
begin
  Socket := INVALID_SOCKET;
  ExtractHostAndFileName(AUrl, Host, FileName);
  try
    InitSocket(Host);
    if FileName = '' then
      FileName := '/';
    Data := SendCommand(Format(SRequestFileHead, [FileName, Host]));
    Data := SendCommand(Format(SRequestDownFile, [FileName, Host]));
    while True do
    begin
      Data := ReceiveLine;
      if Data = '' then break;
      Add(Result, PChar(Data), Length(Data));
      Application.ProcessMessages;
    end;
  finally
    UnInitSocket;
  end;
end;

function TF_Main.GetRingName(aText:String): String;
Var
  i:Integer;
  aStr:String;
begin
  Result := '';
  i:=Pos('铃音名称',aText);
  aStr := Copy(aText,i,Length(aText)-i);
  i := Pos('<td>&nbsp;',aStr);
  aStr := Copy(aStr,i+10,Length(aStr)-i);
  i := Pos('</td>',aStr);
  Result := Copy(aStr,1,i-1);
end;

function TF_Main.GetRingAuthor(aText:String): String;
Var
  i:Integer;
  aStr:String;
begin
  Result := '';
  i:=Pos('歌手',aText);
  aStr := Copy(aText,i,Length(aText)-i);
  i := Pos('<td>&nbsp;',aStr);
  aStr := Copy(aStr,i+10,Length(aStr)-i);
  i := Pos('</td>',aStr);
  Result := Copy(aStr,1,i-1);
end;

Function TF_Main.GetRingprovide(aText:String):String;  //获取提供商
Var
  i:Integer;
  aStr:String;
begin
  Result := '';
  i:=Pos('铃音提供商',aText);
  aStr := Copy(aText,i,Length(aText)-i);
  i := Pos('<td>&nbsp;',aStr);
  aStr := Copy(aStr,i+10,Length(aStr)-i);
  i := Pos('</td>',aStr);
  Result := Copy(aStr,1,i-1);
end;

function TF_Main.GetRingUrl(aText:String): String;
Var
  i:Integer;
  aStr:String;
begin
  Result := '';
  i:=Pos('http://www.fj118100.com/colorring/wav/sys/',aText);
  aStr := Copy(aText,i,Length(aText)-i);
  i := Pos('">',aStr);
  Result := Copy(aStr,1,i-1);
end;

procedure TF_Main.StartDownFile;
begin
  if cbUpdateWb.Checked then
  begin
    ProBar.StepBy(1);
    WbRingInfo.Navigate(MemRingInfoUrl.Text);
    ProBar.StepBy(1);
    WbTryListen.Navigate(MemTryListenUrl.Text);
  end;
  ProBar.StepBy(1);
  MemRingInfoCode.Text := DownloadWithInet(MemRingInfoUrl.Text);
  ProBar.StepBy(1);
  MemTryListenCode.Text := DownloadWithInet(MemTryListenUrl.Text);

  ProBar.StepBy(1);
  MemRingUrl.Text := GetRingUrl(MemTryListenCode.Text);
  if Pos('http://www.fj118100.com/',MemRingUrl.Text)<1 then
  begin
    MemRingUrl.Text := '铃声不存在!';
    ProBar.Position := ProBar.Max;
    //if Timer.Enabled then
      TimerTimer(Nil);
  end else
  begin
    ProBar.StepBy(1);
    edtRingProvider.Text := GetRingprovide(MemRingInfoCode.Text);
    ProBar.StepBy(1);
    edtRingName.Text := GetRingName(MemRingInfoCode.Text);
    ProBar.StepBy(1);
    edtRingAuthor.Text := GetRingAuthor(MemRingInfoCode.Text);

    ProBar.StepBy(1);
    if Pos('http://www.fj118100.com/',MemRingUrl.Text)>0 then
    begin
      if not DirectoryExists(SavePath+edtRingProvider.Text+'\') then
        MkDir(SavePath+edtRingProvider.Text+'\');
      //ShowMessage(SavePath+edtRingProvider.Text+'\'+GetRingName(MemRingInfoCode.Text)+GetExtendName(MemRingUrl.Text));
      FDownFileOb.DownFile(MemRingUrl.Text,SavePath+edtRingProvider.Text+'\'+GetRingName(MemRingInfoCode.Text)+GetExtendName(MemRingUrl.Text));
      Inc(RingDownCount);
      edtRingDownCount.Text := IntToStr(RingDownCount);
    end;
  end;
end;

procedure TF_Main.cbUpdateWbClick(Sender: TObject);
begin
  if cbUpdateWb.Checked then
    ProBar.Max := 9
  else
    ProBar.Max := 7;

  if Timer.Enabled = False then
    ProBar.Position := ProBar.Max;
end;

procedure TF_Main.InitSet;
begin
  Timer.Interval := TimerInterval;
  if cbUpdateWb.Checked then
    ProBar.Max := 7
  else
    ProBar.Max := 9;

  EdtRingFir.Text := RingFir;
  EdtRingSec.Text := RingSec;
  EdtRingThr.Text := RingThr;
  SavePath :=ReadConfig(ConfigIniFileName,'Sys','SavePath');
  if Not DirectoryExists(SavePath) then SavePath:=AppPath;
  edtSavePath.Text := SavePath;
  RingDownCount := ReadConfigInt(ConfigIniFileName,'Sys','RingDownCount');
  edtRingDownCount.Text := IntToStr(RingDownCount);
end;

procedure TF_Main.TimerTimer(Sender: TObject);
begin
  //MaxNum := MaxNum + 1;
  Timer.Enabled := False;
  RingThr:=IntToStr(StrToInt(RingThr)+1);
  if Length(RingThr)=1 then
    RingThr := '000'+RingThr
  else if  Length(RingThr)=2 then
    RingThr := '00'+RingThr
  else if  Length(RingThr)=3 then
    RingThr := '0'+RingThr;

  if StrToInt(RingThr)>2000 then
  begin
    RingFir := IntToStr(StrToInt(RingFir)+1);
    RingThr := '0000';
  end;

  EdtRingFir.Text := RingFir;
  EdtRingSec.Text := RingSec;
  EdtRingThr.Text := RingThr;

  RingUrl := RingFir + RingSec + RingThr;
  //RingThr:=Format('0000',)
  MemRingInfoUrl.Text := RingInfoUrl + RingUrl;
  MemTryListenUrl.Text := TryListenUrl + RingUrl;
  ProBar.Position := 0;
  StartDownFile;
  Timer.Enabled :=True;
end;

procedure TF_Main.bbtnDownClick(Sender: TObject);
begin
  Timer.Enabled := True;
end;

procedure TF_Main.bbtnStopClick(Sender: TObject);
begin
  WriteConfig(IniFileName,'Sys','RingFir',RingFir);
  WriteConfig(IniFileName,'Sys','RingSec',RingSec);
  WriteConfig(IniFileName,'Sys','RingThr',RingThr);
  WriteConfigInt(IniFileName,'Sys','RingDownCount',RingDownCount);

  Timer.Enabled := False;
end;

procedure TF_Main.bbtnApplyClick(Sender: TObject);
begin
  //MaxNum := StrToInt(EdtRingNo.Text);
  RingFir := Trim(EdtRingFir.Text);
  RingSec := Trim(EdtRingSec.Text);
  RingThr := Trim(EdtRingThr.Text);

  WriteConfig(IniFileName,'Sys','RingFir',RingFir);
  WriteConfig(IniFileName,'Sys','RingSec',RingSec);
  WriteConfig(IniFileName,'Sys','RingThr',RingThr);
end;

procedure TF_Main.bbtnBrowerClick(Sender: TObject);
begin
  F_RingSavePath := TF_RingSavePath.Create(nil);
  //F_RingSavePath.dlb.Directory := SavePath;
  if F_RingSavePath.ShowModal = mrOk then
  begin
    edtSavePath.Text := F_RingSavePath.dlb.Directory+'\';
    SavePath := F_RingSavePath.dlb.Directory+'\';
    WriteConfig(IniFileName,'Sys','SavePath',SavePath);
  end;
  {if DirectoryExists(Trim(edtSavePath.Text)) then
    SavePath := Trim(edtSavePath.Text)
  else
    MessageBox(0,'该目录不存在',Prompt,mrNone);}
end;

function TF_Main.GetExtendName(aString: String): String;
var
  i,L:Integer;
begin
  Result := '';
  L:=Length('http://www.fj118100.com/');
  if aString = '' then Exit;
  i:=Pos('http://www.fj118100.com/',aString);
  aString := Copy(aString,i+L,Length(aString)-L);
  i:=Pos('.',aString);
  Result := Copy(aString,i,Length(aString)-i+1);
  //ShowMessage(Result);
end;

procedure TF_Main.lblHomePageClick(Sender: TObject);
Var
  Url:String;
begin
  Url:='http://www.uu007.com';
  try
    ShellExecute(Handle, nil, PChar(Url), nil, nil, SW_SHOWNORMAL);
  except
    Application.MessageBox('Internet Explorer调用失败！', '错误', MB_ICONWARNING);
  end;
end;

end.