u_main.pas

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

unit U_Main;

interface

uses
  Windows,Messages,SysUtils,Variants,Classes,Graphics,Controls,Forms,Dialogs,Menus,
  ComCtrls,ToolWin,ExtCtrls,Series,ImgList,
  StdCtrls,ADODB,
  U_RecordStruct,U_ManagerTree, DB,
  Buttons, DBCtrls, Mask,  ShellAPI, BaseGrid, WinSock, WinInet, OleCtrls,
  SHDocVw, U_TDownFile;

type
  TF_Main = class(TForm)
    StatusBar: TStatusBar;
    Panel3: TPanel;
    Panel4: TPanel;
    Panel5: TPanel;
    MemRingInfoUrl: TMemo;
    Panel6: TPanel;
    Panel8: TPanel;
    Panel9: TPanel;
    MemTryListenUrl: TMemo;
    Panel10: TPanel;
    Timer: TTimer;
    Panel1: TPanel;
    Panel2: TPanel;
    Panel11: TPanel;
    Panel12: TPanel;
    Panel14: TPanel;
    WbRingInfo: TWebBrowser;
    Panel15: TPanel;
    WbTryListen: TWebBrowser;
    Panel7: TPanel;
    MemRingInfoCode: TMemo;
    Panel16: TPanel;
    Panel13: TPanel;
    MemTryListenCode: TMemo;
    Panel17: TPanel;
    Label1: TLabel;
    edtRingName: TEdit;
    Label2: TLabel;
    edtRingAuthor: TEdit;
    Label3: TLabel;
    MemRingUrl: TMemo;
    Panel18: TPanel;
    Panel19: TPanel;
    cbUpdateWb: TCheckBox;
    Label4: TLabel;
    EdtRingFir: TEdit;
    bbtnApply: TBitBtn;
    EdtRingSec: TEdit;
    EdtRingThr: TEdit;
    Label5: TLabel;
    edtRingProvider: TEdit;
    Label6: TLabel;
    edtSavePath: TEdit;
    bbtnBrower: TBitBtn;
    Panel20: TPanel;
    Label9: TLabel;
    lblHomePage: TLabel;
    Label13: TLabel;
    Label14: TLabel;
    Label8: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    ProBar: TProgressBar;
    Label7: TLabel;
    edtRingDownCount: TEdit;
    bbtnStop: TBitBtn;
    bbtnDown: TBitBtn;
    Memo: TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure sbHelpClick(Sender: TObject);
    procedure cbUpdateWbClick(Sender: TObject);
    procedure TimerTimer(Sender: TObject);
    procedure bbtnDownClick(Sender: TObject);
    procedure bbtnStopClick(Sender: TObject);
    procedure bbtnApplyClick(Sender: TObject);
    procedure bbtnBrowerClick(Sender: TObject);
    procedure lblHomePageClick(Sender: TObject);
  private
    //CurDayFrom,CurDayTo,CurWeekFrom,CurWeekTo,CurMonthFrom,CurMonthTo:TDateTime;
    GateID : Integer;
    FDownFileOb:TDownFile;

    procedure AppHint(Sender:TObject);   //系统提示
    Procedure CreateAndInitComponents;   //创建和初始化组件
    Procedure InitExecADOQry;            //初始化ADOQry

    function DownloadWithInet(const AUrl: string): string;
    function DownloadWithSocket(const AUrl: string): string;

    Function GetRingName(aText:String):String;    //获取铃声名称
    Function GetRingAuthor(aText:String):String;  //获取铃声作者
    Function GetRingprovide(aText:String):String;  //获取提供商    
    Function GetRingUrl(aText:String):String;     //获取铃声地址

    Function GetExtendName(aString:String):String;//获取文件扩展名

    Procedure StartDownFile;
    Procedure InitSet;
    { Private declarations }
  public
    { Public declarations }
  end;

var
  F_Main: TF_Main;

implementation

  Uses U_OtherPublicPack,U_DBPublicPack,U_PulicPack,U_StringPublicPack,
    StdConvs, DateUtils,U_SysSet, ComObj, Math, U_RingSavePath, FileCtrl;

{$R *.dfm}

{ TF_Main }

procedure TF_Main.AppHint(Sender: TObject);
begin
  If F_Main<>Nil Then
    StatusBar.Panels[2].Text:=Application.Hint;
  If application.Hint='' THen
    StatusBar.Panels[2].Text:='若有任何疑问，可找小任提出修改意见！：）';
end;

procedure TF_Main.CreateAndInitComponents;
Var
  ServerName,UserName,Password:String;
begin
  ADOConnection:=TADOConnection.Create(nil);
  ADOConnection.LoginPrompt:=False;
  //读取数据库连接配置数据
  ServerName:=ReadConfig(IniFileName,'DataBase','ServerName');
  DataBaseName:=ReadConfig(IniFileName,'DataBase','DataBaseName');
  UserName:=ServerLoginUserName;
  Password:=ServerLoginUserPwd;
  DBConnectionString:=GetDBConnectionString(ServerName,DataBaseName,UserName,Password);
  ConnectDataBase(ADOConnection,DBConnectionString);

  ADOCntCustomer := TADOConnection.Create(nil);
  ADOCntCustomer.LoginPrompt:=False;
  CustomerDB:=ReadConfig(IniFileName,'DataBase','CustomerDBName');
  CustomerConnectionString:= GetDBConnectionString(ServerName,CustomerDB,UserName,Password);
  ConnectDataBase(ADOCntCustomer,CustomerConnectionString);
  //Begin----------------------------------------------------------------------------------

  ADOQryTemp:=TADOQuery.Create(Nil);
  ADOQryTemp.ConnectionString:=TableCfgDBConnectionString;

  //end------------------------------------------------------------------------------------
end;


procedure TF_Main.InitExecADOQry;
begin

end;

procedure TF_Main.FormCreate(Sender: TObject);
begin
  //初始化信息
  AppPath := ExtractFilePath(ParamStr(0));
  Application.OnHint := AppHint;
  //CreateAndInitComponents;
  FDownFileOb := TDownFile.Create(nil);
  RingUrl := RingFir + RingSec + RingThr;

  InitSet;
end;

procedure TF_Main.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Timer.Enabled := False;
  WriteConfig(IniFileName,'Sys','RingFir',RingFir);
  WriteConfig(IniFileName,'Sys','RingSec',RingSec);
  WriteConfig(IniFileName,'Sys','RingThr',RingThr);
  WriteConfigInt(IniFileName,'Sys','RingDownCount',RingDownCount);

  FDownFileOb.Destroy;
  Application.Terminate;
end;


procedure TF_Main.sbHelpClick(Sender: TObject);
Var
  aHelp:String;
begin
  aHelp:=AppPath+'Help.txt';
  if FileExists(aHelp) then
    ShellExecute(0, 'open', Pchar(aHelp), nil, nil, SW_SHOWNORMAL)
  else
    MessageBox(0,'暂时没有帮助文档，若有任何疑问或建议，可找小任提出修改意见！：）', Prompt ,mrNone);
end;

function TF_Main.DownloadWithInet(const AUrl: string): string;

  procedure Add(Buf: PChar; Count: Integer);
  var
    Len: Integer;
  begin
    Len := Length(Result);
    SetLength(Result, Len + Count);
    Move(Buf^, Result[Len + 1], Count);
  end;

  function PrepareURL: string;
  begin
    Result := UpperCase(Copy(AUrl, 1, 7));
    if Result <> 'HTTP://' then
      Result := 'http://' + AUrl
    else
      Result := AUrl;
  end;

var
  BytesRead: DWORD;
  Session, Connection: HINTERNET;
  Buffer: array[1..1024] of Char;
begin
  Result := '';
  if AUrl = '' then Exit;
  Session := InternetOpen(nil, INTERNET_OPEN_TYPE_DIRECT, nil, nil, 0);
  if not Assigned(Session) then
    raise Exception.Create(SysErrorMessage(GetLastError));
  try
    Connection := InternetOpenUrl(Session, PChar(PrepareURL), nil, 0,
        INTERNET_FLAG_RAW_DATA, {INTERNET_FLAG_RELOAD, }0);
    if not Assigned(Connection) then
      raise Exception.Create(SysErrorMessage(GetLastError));
    try
      repeat
        FillChar(Buffer, SizeOf(Buffer), 0);
        InternetReadFile(Connection, @Buffer, SizeOf(Buffer), BytesRead);
        if BytesRead > 0 then
          Add(@Buffer, BytesRead);
        Application.ProcessMessages;
      until BytesRead = 0;
    finally
      InternetCloseHandle(Connection);
    end;
  finally
    InternetCloseHandle(Session);
  end;
  Result := Trim(Result);
end;

function TF_Main.DownloadWithSocket(const AUrl: string): string;
const
  CRLF = #13#10;
  SFileContentLen = 'content-length: ';
  SUserAgent =
    'User-Agent: Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; .NET CLR 1.0.3705)';
  SRequestFileHead =
    'HEAD %s HTTP/1.1' + CRLF +
    'Pragma: no-cache' + CRLF +
    'Cache-Control: no-cache' + CRLF +
    SUserAgent + CRLF +
    'Host: %s' + CRLF + CRLF;
  SRequestDownFile =
    'GET %s HTTP/1.1' + CRLF +
    'Accept: */*' + CRLF +
    SUserAgent + CRLF +
    'RANGE: bytes=0-' + CRLF +
    'Host: %s' + CRLF + CRLF;

  procedure ExtractHostAndFileName(const AURL: string;
    var AHost, AFileName: string; APort: PString = nil);
  const
    HttpHead = 'http://';
    HttpHeadLen = Length(HttpHead);
  var
    I: Integer;
  begin
    AHost := AURL;
    I := Pos(HttpHead, AURL);
    if I <> 0 then
      AHost := Copy(AHost, I + HttpHeadLen, MaxInt);
    I := AnsiPos('/', AHost);
    while I <> 0 do
    begin
      AHost := Copy(AHost, 1, I - 1);
      I := AnsiPos('/', AHost);
    end;
    I := Pos(AHost, AURL) + Length(AHost);
    AFileName := Copy(AURL, i, MaxInt);
    I := Pos(':', AHost);
    if I <> 0 then
    begin
      if Assigned(APort) then
        APort^ := Copy(AHost, I + 1, MaxInt);
      AHost := Copy(AHost, 1, I - 1);
    end;
  end;

var
  Socket: TSocket;

  function WaitForSocket(Timeout: Integer): Boolean;
  var
    FDSet: TFDSet;
    TimeVal: TTimeVal;
  begin
    TimeVal.tv_sec := Timeout;
    TimeVal.tv_usec := 0;
    FD_ZERO(FDSet);
    FD_SET(Socket, FDSet);
    Result := WinSock.select(0, @FDSet, nil, nil, @TimeVal) > 0;
  end;

  procedure Add(var S: string; Buf: PChar; Count: Integer);
  var
    Len: Integer;
  begin
    Len := Length(S);
    SetLength(S, Len + Count);
    Move(Buf^, S[Len + 1], Count);