main.pas.~16~

delphi写的http的download来Update的源码

unit main;

interface

uses
    Windows, Messages, SysUtils, Variants, Classes, Graphics
    , Controls, Forms,
    Dialogs
  , UrlMon
  , StrUtils
  , autoupdate
  , Gauges
  , ComCtrls
  , StdCtrls
  , FileCtrl
  , ExtActns
  ;

type

//  TCallback = class (TInterfacedObject,IBindStatusCallback);


  MD5Digest = array[0..15] of Byte;

  TForm1 = class(TForm)
    Label1: TLabel;
    cbb1: TComboBox;
    Label2: TLabel;
    lv1: TListView;
    g1: TGauge;
    Label3: TLabel;
    lblCount: TLabel;
    Label4: TLabel;
    lblSpeed: TLabel;
    chk1: TCheckBox;
    chk2: TCheckBox;
    btn1: TButton;
    procedure FormShow(Sender: TObject);
    procedure chk1Click(Sender: TObject);
    procedure chk2Click(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure btn1Click(Sender: TObject);
  private
    xmlHash:string;
    remoteUrl:string;
    LocalPath:string;
    filePathList:TStringList;
    UpdateString:TStringList;
    { Private declarations }
//    function downFile(aURL,apath:string): boolean;
    function adjustPath(apath:string): string;
    function checkFiles(): boolean;
    procedure intLV(lv:TListView);
    procedure intCbb(Cbb:TCombobox);
    function intUpdate(lv:TListView): boolean;
    function DownloadFile(SourceFile, DestFile: string): Boolean;
    procedure URL_OnDownloadProgress(Sender: TDownLoadURL;
          Progress, ProgressMax: Cardinal;
          StatusCode: TURLDownloadStatus;
          StatusText: String; var Cancel: Boolean) ;

  public
    { Public declarations }
  end;

const
  FILENOTEXIST='File doesn''t exist!';
  DOWNERROR='Download file error!';


var
  Form1: TForm1;
  myCfg:IXMLConfigType;


implementation

function MD5String(M: string): MD5Digest;stdcall;external 'md5hash.dll';
function MD5File(N: string): MD5Digest;stdcall;external 'md5hash.dll';
function MD5Print(D: MD5Digest): string;stdcall;external 'md5hash.dll';
function MD5Match(D1, D2: MD5Digest): boolean;stdcall;  external 'md5hash.dll';

{$R *.dfm}

{ TForm1 }

function TForm1.adjustPath(apath: string): string;
begin
  apath:=StringReplace(apath,'/','\',[rfReplaceAll]);
  while RightStr(apath,1)='\' do
  begin
     apath:=Copy(apath,1,Length(apath)-1);
  end;
  Result:=apath;
end;

procedure TForm1.btn1Click(Sender: TObject);
var
  i,n:Integer;
  s,s1:string;
//  fs:TFileStream;
begin
  if (cbb1.Items.Count=0)or(lv1.Items.Count=0) then
  begin
    ShowMessage('null');
    Exit;
  end;
  if intUpdate(lv1) then
    begin

      for I := 0 to UpdateString.Count - 1 do
      begin
          n:=Pos('@',UpdateString[i]);
          s1:=Copy(UpdateString[i],1,n-1);
          s:=Copy(UpdateString[i],n+1,Length(UpdateString[i])-n);
         if FileExists(s) then
           DeleteFile(s);
//          fs:=TFileStream.Create(s,fmCreate);
          if not DirectoryExists(ExtractFileDir(s)) then
             ForceDirectories(ExtractFileDir(s));
          Sleep(100);
         if DownloadFile(s1,s) then
         begin
           Sleep(200);
//           fs.Free;
         end;
      end;
      ShowMessage('所有更新下载完成');
    end
    else
    begin
      ShowMessage('必须升级的选项，必须被勾选上');
      Exit;
    end;

end;

function TForm1.checkFiles: boolean;
var
  i:Integer;
  newItem:TListItem;
begin
  Result:=False;
  filePathList:=TStringList.Create;
   myCfg:=Loadconfig(LocalPath+'\autoupdate.xml');
   with myCfg.FileList do
   begin
     for I := 0 to Count - 1 do
       begin
         if (FileInfo[i].FileHash
              <>
                 MD5Print(MD5File(LocalPath+'\'+FileInfo[i].FilePath)))
              or
                  (not FileExists(LocalPath+'\'+fileinfo[i].FilePath))
         then
         begin
           Result:=True;
           newItem:=lv1.Items.Add;
           newItem.Caption:='';
           newItem.SubItems.Add(FileInfo[i].FileName);
           newItem.SubItems.Add(FileInfo[i].FileVersion);
           newItem.SubItems.Add(FileInfo[i].FileLevel);
           filePathList.Add(FileInfo[i].FilePath);
         end;

       end;
   end;

end;

procedure TForm1.chk1Click(Sender: TObject);
var
  i:Integer;
begin
  for I := 0 to lv1.Items.Count - 1 do
    begin
      lv1.Items[i].Checked:=chk1.Checked;
    end;
    chk2.Checked:=chk1.Checked;
end;

procedure TForm1.chk2Click(Sender: TObject);
var
  i:Integer;
begin
  with lv1 do
  begin
     for I := 0 to Items.Count - 1 do
     begin
       if StrToBool(Items[i].SubItems[2]) then
        Items[i].Checked:=chk2.Checked;
//        ShowMessage(Items[i].SubItems[1]);
     end;
  end;
end;

function TForm1.DownloadFile(SourceFile, DestFile: string): Boolean;
 var
  hasError: boolean;
 begin
   hasError:=false;
  with TDownloadURL.Create(self) do
   try
     URL:=SourceFile;
     FileName := DestFile;
     OnDownloadProgress := URL_OnDownloadProgress;
     ExecuteTarget(nil) ;
   except on e: Exception do begin
      ShowMessage(e.Message);
    Free;
     hasError:=true;
     end;
   end;
   Result := not hasError;
 end;


//function TForm1.downFile(aURL,apath: string): boolean;
//begin
//  with TDownloadURL.Create(self) do
//    try
//      URL:=aURL;
//      FileName :=apath;
//      OnDownloadProgress := URL_OnDownloadProgress;
//
//      ExecuteTarget(nil) ;
//      finally
//        Free;
//      end;
//    end;


procedure TForm1.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  filePathList.Free;
  UpdateString.Free;
end;

procedure TForm1.FormShow(Sender: TObject);
var
  F1:TextFile;
  s:string;
begin
  remoteUrl:='http://127.0.0.1:1527';
  LocalPath:=adjustPath(ExtractFilePath(Application.ExeName));
  //-----------------------------------------------------------------
  if DownloadFile(remoteUrl+'/xmlCode.txt',LocalPath+'\xmlCode.txt') then
    begin
      try
          //read the xmlhash code;
         AssignFile(F1,'xmlCode.txt');
         Reset(F1);
         xmlHash:='';
         while not Eof(F1) do
         begin
           Readln(F1,s);
           xmlHash:=xmlHash+s;
         end;
         xmlHash:=Trim(xmlHash);
         //need to download autoupdate.xml or not
         if (not FileExists(LocalPath+'\autoupdate.xml'))
          or
            (xmlHash<>MD5Print(MD5File(LocalPath+'\autoupdate.xml'))) then
          begin
            DownloadFile(remoteUrl+'/autoupdate.xml',LocalPath+'\autoupdate.xml')
          end
       finally
         CloseFile(F1);
       end;
       intLV(lv1);
       //return while or not
      if not checkFiles then
        Close;
      intCbb(cbb1);
    end
    else  //download xmlCode.txt error
    ShowMessage(DOWNERROR);

//   ShowMessage(xmlHash);
end;

procedure TForm1.intCbb(Cbb: TCombobox);
var
  i:Integer;
begin
  with Cbb do
  begin
     Items.Clear;
     with myCfg do
     begin
        for I := 0 to SrvList.Count  - 1 do
           begin
             Items.Append(SrvList.SrvInfo[i].SrvName);
           end;
     end;
     ItemIndex:=0;
  end;
end;

procedure TForm1.intLV(lv: TListView);
var
//  CaptionArr:array[0..2] of string;
//  nwidth,i:Integer;
  nwidth:Integer;
  newItem:TListColumn;
begin
   lv.Items.Clear;
   lv.ViewStyle:=vsReport;
   lv.Checkboxes:=True;
   nwidth:=Round((lv.Width-50)/3);
   //-------------------------
   with lv do
   begin
     newItem:=Columns.Add;
     newItem.Caption:='升级';
     newItem.Width:=50;
     newItem:=Columns.Add;
     newItem.Caption:='文件名';
     newItem.Width:=nwidth;
     newItem:=Columns.Add;
     newItem.Caption:='版本号';
     newItem.Width:=nwidth;
     newItem:=Columns.Add;
     newItem.Caption:='必须';
     newItem.Width:=nwidth;

   end;
   lv.AlphaSort;
end;

function TForm1.intUpdate(lv: TListView): boolean;
var
  i:Integer;
  s,s1:string;
  srvURL:string;
begin
  Result:=True;
  UpdateString:=TStringList.Create;
  UpdateString.Clear;
  srvURL:=myCfg.SrvList.SrvInfo[cbb1.ItemIndex].SrvPath;
  for I := 0 to lv.Items.Count - 1 do
    begin
      s:='';
       if lv.Items[i].Checked then
       begin

          s:=StringReplace(srvURL+'/'+filepathList[i],'\','/',[rfReplaceAll]);
          s1:=StringReplace(LocalPath+'\'+filepathlist[i],'/','\',[rfReplaceAll]);
          s:=s+'@'+s1;
          UpdateString.Add(s);
       end;
       if (not lv.Items[i].Checked)and(StrToBool(lv.Items[i].SubItems[2])) then
       begin
          Result:=False;
          Exit;
       end;

    end;
end;


procedure TForm1.URL_OnDownloadProgress(Sender: TDownLoadURL; Progress,
  ProgressMax: Cardinal; StatusCode: TURLDownloadStatus; StatusText: String;
  var Cancel: Boolean);
begin
    g1.MaxValue:=ProgressMax;
    g1.Progress:=Progress;
    Application.ProcessMessages;
end;

end.