main.pas

自动升级的程序,支持断点下载,稍微修改一下就可以适用了任何文件的升级

unit Main;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs,Registry, StdCtrls,shellapi, WinSkinData, ComCtrls, ExtCtrls,
  Buttons, ImgList, IdFTP, IdBaseComponent, IdComponent, IdTCPConnection,
  IdTCPClient, IdHTTP,IniFiles;

type
  TFrm_Main = class(TForm)
    Memo1: TMemo;
    SkinData1: TSkinData;
    btn_Update: TBitBtn;
    PB_Cur: TProgressBar;
    Panel1: TPanel;
    Image1: TImage;
    PB_Whole: TProgressBar;
    Label2: TLabel;
    Label1: TLabel;
    Btn_Cancel: TBitBtn;
    IdHTTP1: TIdHTTP;
    IdFTP1: TIdFTP;
    Label3: TLabel;
    procedure btn_UpdateClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormShow(Sender: TObject);
    procedure Btn_CancelClick(Sender: TObject);
    procedure IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCount: Integer);
    procedure IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;
      const AWorkCountMax: Integer);
    procedure IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    LocalVer,NetVer:Double;
    LocalVerStr,NetVerStr:String;
    SQLCount:integer;  //需执行SQL的总数
    nDownFileCount:integer; //需下载的文件数
    DispStr:String;   //显示正在执行哪个动作的信息
    procedure CreateScript;
    procedure RunScript(const sSQL: String);
    function  GetFileVer(const AFileName: string;AIndex:integer): Cardinal;
    function  GetFileVerStr(AFileName:String): String;
    procedure ClearReg;
    procedure WriteErrLog(ErrStr:String);
  private
    AbortTransfer: Boolean; //是否中断
    BytesToTransfer: LongWord; //下载总大小
    aHint,NoRunSQL:Boolean;
    WinPath,TmpURL,MyURL:String;
    NetIni:TIniFile;
    WebStr:String;
    procedure FtpDownLoad(aURL, aFile: string; bResume: Boolean);
    procedure HttpDownLoad(aURL, aFile: string; bResume: Boolean);
    procedure MyDownLoad(aURL, aFile: string; bResume: Boolean);
    function  GetProt(aURL: string): Byte;
    function  GetURLFileName(aURL: string): string;
    procedure GetFTPParams(aURL: string; var sName, sPass, sHost, sPort,sDir: string);  
    procedure BakOldFile;
    procedure DownNetUpdateIni;
    procedure DispPanelVer;
    procedure DownAFile(aName:String);
  public
    { Public declarations }
  end;

var
  Frm_Main: TFrm_Main;
  TxtFile:TextFile;
  DownList,ExeList:TStringList;
  AverageSpeed: Double = 0;
implementation

uses DM, DBTables, DB, ADODB;

{$R *.dfm}

//检测下载的地址是http还是ftp
function TFrm_Main.GetProt(aURL: string): Byte;
begin
  Result := 0;
  if Pos('http', LowerCase(aURL))= 1 then  Result := 1; //http协议
  if Pos('ftp', LowerCase(aURL)) = 1 then  Result := 2; //ftp协议
end;

 //返回下载地址的文件名
function TFrm_Main.GetURLFileName(aURL: string): string;
var
  i: integer;
  s: string;
begin
  s := aURL;
  i := Pos('/', s);
  while i <> 0 do //去掉"/"前面的内容剩下的就是文件名了
    begin
      Delete(s, 1, i);
      i := Pos('/', s);
    end;
  Result := s;
end;

//分析ftp地址的登陆用户名，密码和目录
procedure TFrm_Main.GetFTPParams(aURL: string; var sName, sPass, sHost, sPort, sDir: string);
var
  i, j: integer;
  s, tmp: string;
begin
  s := aURL;
  if Pos('ftp://', LowerCase(s)) <> 0 then  Delete(s, 1, 6);//去掉ftp头
  i := Pos('@', s);
  if i <> 0 then //地址含用户名，也可能含密码
    begin
      tmp := Copy(s, 1, i - 1);
      s := copy(s, i+1, Length(s));
      j := Pos(':', tmp);
      if j <> 0 then //包含密码
        begin
          sName := Copy(tmp, 1, j - 1); //得到用户名
          sPass := Copy(tmp, j + 1, i - j - 1); //得到密码
        end
      else
        begin
          sName := tmp;
          sPass := Inputbox('输入框','请输入登陆ftp密码','');
        end;
    end
  else //匿名用户
    begin
      sName := 'anonymous';
      sPass := '[e-mail]';
    end;
  i := Pos(':', s);
  j := Pos('/', s);
  sHost := Copy(s, 1, j - 1); //主机
  if i <> 0 then  sPort := Copy(s, i + 1, j - i - 1)//含端口
  else  sPort := '21'; //默认21端口
  tmp := Copy(s, j + 1, Length(s));
  while j <> 0 do
    begin
      Delete(s, 1, j);
      j := Pos('/', s);
    end; //目录
  sDir := '/' + Copy(tmp, 1, Length(tmp) - Length(s) - 1);
end;

//ftp方式下载
procedure TFrm_Main.FtpDownLoad(aURL, aFile: string; bResume: Boolean);
var
  tStream: TFileStream;
  sName, sPass, sHost, sPort, sDir: string;
begin
  if FileExists(aFile) then tStream := TFileStream.Create(aFile, fmOpenWrite)
  else  tStream := TFileStream.Create(aFile, fmCreate); //建立文件流
  GetFTPParams(aURL, sName, sPass, sHost, sPort, sDir);
  with IdFTP1 do
  try
    if Connected then Disconnect; //重新连接
    Username := sName;
    Password := sPass;
    Host := sHost;
    Port := StrToInt(sPort);
    Connect;
  except
    exit;
  end;

  IdFTP1.ChangeDir(sDir); //改变目录
  BytesToTransfer := IdFTP1.Size(aFile);
  try
    if bResume then //续传
      begin
        tStream.Position := tStream.Size;
        IdFTP1.Get(aFile, tStream, True);
      end
    else
      begin
        IdFTP1.Get(aFile, tStream, False);
      end;
  finally
    tStream.Free;
  end;
end;

//http方式下载
procedure TFrm_Main.HttpDownLoad(aURL, aFile: string; bResume: Boolean);
var
  tStream: TFileStream;
begin
  try
     //如果文件已经存在
    if FileExists(aFile) then tStream := TFileStream.Create(aFile, fmOpenWrite)
    else tStream := TFileStream.Create(aFile, fmCreate);
    if bResume then //续传方式
      begin
        IdHTTP1.Request.ContentRangeStart := tStream.Size - 1;
        tStream.Position := tStream.Size - 1; //移动到最后继续下载
        IdHTTP1.Head(aURL);
        IdHTTP1.Request.ContentRangeEnd := IdHTTP1.Response.ContentLength;
      end
    else //覆盖或新建方式
      begin
        IdHTTP1.Request.ContentRangeStart := 0;
      end;
    try
      IdHTTP1.Get(aURL, tStream); //开始下载
    finally
      tStream.Free;
    end;
  Except
    on E:Exception do
      begin
        if (Pos('Operation aborted',E.Message)>=0) and AbortTransfer then
          begin
            E.Message:='已被用户中断';
          end;
        Application.MessageBox(PChar('升级过程中出现了错误了,错误信息如下：'+#13+#13+E.Message),PChar('系统提示'),Mb_OK+MB_ICONERROR);
        WriteErrLog('升级过程中出现了错误了,错误信息如下：'+E.Message);
        CopyFile(PChar(ExtractFilePath(ParamStr(0))+'Bak\KQSys.exe'),PChar(ExtractFilePath(ParamStr(0))),False);
        Abort;
      end;
  end;
end;

procedure TFrm_Main.MyDownLoad(aURL, aFile: string; bResume: Boolean);
begin
  case GetProt(aURL) of
    0: Application.MessageBox(PChar('不可识别的地址'),PChar('系统提示'),Mb_OK+MB_ICONERROR);
    1: HttpDownLoad(aURL, aFile, bResume);
    2: FtpDownLoad(aURL, aFile, bResume);
  end;
end;


procedure TFrm_Main.btn_UpdateClick(Sender: TObject);
var
  aURL, aFile: string;
  LStr:string;
  i:integer;
  dFileName,LangFold:string; //网络上Ini文件名(如Language\CHS.INI)跟语言文件夹
  aFileName:String;  //去掉路径后的文件名
begin
  DispStr:='正在下载新版本文件%S,请稍候...';
  try
    Screen.Cursor:=crSQLWait;
    btn_Update.Enabled:=False;
    Btn_Cancel.Caption:='中断升级';
    try
      Label3.Caption:='正在获取升级配置文件,请稍候...';
      Refresh;
      DownNetUpdateIni;
    except
      on  E:Exception do
        begin
          Application.MessageBox(PChar('获取升级配置文件失败，请梢候重试'+#13+#13+E.Message),PChar('系统提示'),MB_OK+MB_ICONERROR);
          WriteErrLog('获取升级配置文件失败，错误信息如下:'+E.Message);
          Exit;
        end;
    end;
    with PB_Whole do
      begin
        Max:=6+2*nDownFileCount;
        Min:=0;
        Step:=1;
      end;

    Label3.Caption:='正在启动升级配置文件...';
    DispPanelVer;
    PB_Whole.StepIt;
    Refresh;

    Label3.Caption:='正在备份旧版本文件,请稍候...';
    BakOldFile;
    PB_Whole.StepIt;
    Refresh;

   //下载新版本的文件 
    for i:=0 to DownList.Count-1 do
      begin
        dFileName:=Copy(DownList.Strings[i],Pos('=',DownList.Strings[i])+1,Length(DownList.Strings[i]));
        if Pos('\',dFileName)>0 then
          begin
            LangFold :=copy(dFileName,0,Pos('\',dFileName)-1);
            aFileName:=copy(dFileName,Pos('\',dFileName)+1,Length(dFileName));
            Label3.Caption:=Format(DispStr,[aFileName]);
            Refresh;
            DownAFile(aFileName);
          end
        else
          begin
            Label3.Caption:=Format(DispStr,[dFileName]);
            Refresh;
            DownAFile(dFileName);
          end;
        PB_Whole.StepIt;  
      end;

    ClearReg;
    PB_Whole.StepIt;

    Memo1.Lines.LoadFromFile(ExtractFilePath(ParamStr(0))+'UpdateSQL.dll');
    DeleteFile(ExtractFilePath(ParamStr(0))+'UpdateSQL.dll');
    Label3.Caption:='正在更新数据库信息，请稍侯...';
    Refresh;
    CreateScript;
    PB_Whole.StepIt;

    Label3.Caption:='正在更新本地程序，请稍侯...';
    Refresh;
    CopyFile(PChar('CHS.ini'),PChar(ExtractFilePath(ParamStr(0)+'Language\CHS.ini')),False);
    CopyFile(PChar('CHT.ini'),PChar(ExtractFilePath(ParamStr(0)+'Language\CHT.ini')),False);
    CopyFile(PChar('MenuConf.ini'),PChar(WinPath+'MenuConf.ini'),False);
    Ini:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'SysData\Update.ini');
    with Ini do
      begin
        WriteString('WWW','URL',WebStr);
        Free;
      end;
    PB_Whole.StepIt;


    DeleteFile('CHS.INI');
    DeleteFile('CHT.INI');
    DeleteFile('MenuConf.INI');
    PB_Whole.StepIt;
    Application.MessageBox(PChar('恭喜，程序已经升级到最新版本'),PChar('系统提示'),MB_OK+MB_ICONINFORMATION);
  finally
    btn_Update.Enabled:=True;
    Screen.Cursor:=crDefault;