main.pas

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

    PB_Cur.Position:=0;
    PB_Whole.Position:=0;
  end;
  Close;
end;

//创建数据库脚本(一个一个对象)
procedure TFrm_Main.CreateScript;
const
  sTAG = ';';
var
  Str : String;
  sSQL : String;
  iPos : Integer;
begin
  with PB_Cur do
    begin
      Max:=SQLCount;
      Min:=0;
      Step:=1;
    end;
  Str := Trim(Memo1.Lines.Text);
  while True do
    begin
      iPos := Pos(sTAG, Str);
      if (iPos > 0) then
        begin
          sSQL := Copy(Str, 1, iPos - 1);
          if not NoRunSql then RunScript(sSQL);
          Sleep(100);
          PB_Cur.StepIt;
          Delete(Str, 1, iPos);
          Application.ProcessMessages;
        end;
      if (Length(Str) = 0) then  break;
    end;
end;

//运行每个脚本
procedure TFrm_Main.RunScript(const sSQL: String);
begin
  Frm_DM.ADOQuery1.SQL.Text := sSQL;
  try
    Frm_DM.ADOQuery1.ExecSQL;
  except
    on E:Exception  do
      begin
         ShowMessage(E.Message);
         WriteErrLog(E.Message);
      end;
  end;
end;


procedure TFrm_Main.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action:=caFree;
end;

//得到要升级文件版本
function TFrm_Main.GetFileVer(const AFileName: string;AIndex:integer): Cardinal;
var
  FileName: string;
  InfoSize, Wnd: DWORD;
  VerBuf: Pointer;
  FI: PVSFixedFileInfo;
  VerSize: DWORD;
begin
  Result := Cardinal(-1);
  FileName := AFileName;
  UniqueString(FileName);
  InfoSize := GetFileVersionInfoSize(PChar(FileName), Wnd);
  if InfoSize <> 0 then
  begin
    GetMem(VerBuf, InfoSize);
    try
      if GetFileVersionInfo(PChar(FileName), Wnd, InfoSize, VerBuf) then
        if VerQueryValue(VerBuf, '\', Pointer(FI), VerSize) then
          begin
            if AIndex=1      then    Result:= FI.dwFileVersionMS
            else if AIndex=2 then    Result:= FI.dwFileVersionLS;
          end;
    finally
      FreeMem(VerBuf);
    end;
  end;
end;


//得到要升级文件版本
function TFrm_Main.GetFileVerStr(AFileName:String): String;
var
	FileVersion: Cardinal;
	Major1, Major2, Minor1, Minor2: Integer;
begin
	FileVersion := GetFileVer(AFileName,1);
	Major1 := FileVersion shr 16;
	Major2 := FileVersion and $FFFF;

	FileVersion := GetFileVer(AFileName,2);
	Minor1 := FileVersion shr 16;
	Minor2 := FileVersion and $FFFF;
	Result := Format('%d.%d.%d.%d', [Major1, Major2, Minor1, Minor2] );
end;

procedure TFrm_Main.FormCreate(Sender: TObject);
var
  MyPath:String;
begin
  SetLength(MyPath,100);
  GetWindowsDirectory(Pchar(MyPath),100);
  SetLength(MyPath,strLen(Pchar(MyPath)));
  WinPath:=Trim(MyPath)+'\';
end;

procedure TFrm_Main.FormShow(Sender: TObject);
var
  WebIni:TIniFile;
begin
  DownList:=TStringList.Create;
  ExeList :=TStringList.Create;  
  Panel1.Caption:='欢迎使用考勤管理软件智能升级程序';
  WebIni:=TIniFile.Create(ExtractFilePath(ParamStr(0))+'SysData\Update.ini');
  with WebIni do
     TmpURL:=ReadString('WWW','URL','http://free.efile.com.cn/');
  MyURL:=TmpURL+'vagrant/KQ/';   
  WebIni.Free;
end;

procedure TFrm_Main.Btn_CancelClick(Sender: TObject);
begin
  if not btn_Update.Enabled then
    begin
      if Application.MessageBox(PChar('文件还没有下载完毕，确认要中断吗？'),PChar('系统提示'),MB_YESNO+MB_ICONQUESTION)=IDNo then Exit;
      AbortTransfer := True;
    end
  else
    begin
      if Application.MessageBox(PChar('确认要退出程序吗？'),PChar('系统提示'),MB_YESNO+MB_ICONQUESTION)=IDNo then Exit;    
    end;
end;

procedure TFrm_Main.IdHTTP1Work(Sender: TObject; AWorkMode: TWorkMode;const AWorkCount: Integer);
begin
  try
    if AbortTransfer then
      begin //中断下载
        IdHTTP1.Disconnect;
        IdFTP1.Abort;
      end;
    PB_Cur.Position := AWorkCount;
    Application.ProcessMessages;
  except
    WriteErrLog('错误，出现在事件IdHTTP1Work中');
  end;
end;

procedure TFrm_Main.IdHTTP1WorkBegin(Sender: TObject; AWorkMode: TWorkMode;const AWorkCountMax: Integer);
begin
  try
    AbortTransfer := False;
    if AWorkCountMax > 0 then PB_Cur.Max := AWorkCountMax
    else  PB_Cur.Max := BytesToTransfer;
  except
    WriteErrLog('错误，出现在事件IdHTTP1WorkBegin中');
  end;
end;

procedure TFrm_Main.IdHTTP1WorkEnd(Sender: TObject; AWorkMode: TWorkMode);
begin
  if AbortTransfer then
    begin
//      Application.MessageBox(PChar('升级失败，已被用户中断'),PChar('系统提示'),MB_OK+MB_ICONERROR);
      Abort;
      Application.Terminate;
    end
  else
    begin
      if aHint then Application.MessageBox(PChar('OK,程序升级成功!'),PChar('系统提示'),MB_OK+MB_ICONINFORMATION);
    end;
  PB_Cur.Position := 0;
end;

procedure TFrm_Main.ClearReg;
var
  MyReg:TRegistry;
  Code,ID,DT:String;
  aDate,DDate:TDate;
begin
  aDate:=Date;
  DDate:=EncodeDate(2004,12,31);
  if aDate<DDate then
    begin
       //
    end;
end;

procedure TFrm_Main.BakOldFile;
var
  BakPath,aFiles:String;
  i:integer;
  dFileName,LangFold:String;
begin
  BakPath:=ExtractFilePath(ParamStr(0))+'Bak';
  if not DirectoryExists(BakPath) then ForceDirectories(BakPath);
  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);
          if not DirectoryExists(BakPath+'\'+LangFold) then ForceDirectories(BakPath+'\'+LangFold);
        end;
      CopyFile(PChar(ExtractFilePath(ParamStr(0))+dFileName),PChar(BakPath+'\'+dFileName),False);
      PB_Whole.StepIt;        
    end;  
end;

procedure TFrm_Main.DownNetUpdateIni;
var
  aURL,aFile:String;
  FileStr:TStringList;
  i:integer;
begin
  FileStr:=TStringList.Create;
  aURL := MyURL+'NetUpdate.ini';
  FileStr.Add(IdHTTP1.Get(aURL));
  FileStr.SaveToFile(WinPath+'NetUpdate.ini');
  FileStr.Free;
  NetIni:=TIniFile.Create(WinPath+'NetUpdate.ini');
  with NetIni do
    begin
      ReadSectionValues('FilesList',DownList);
      ReadSectionValues('Exe FileList',ExeList);
      NetVerStr:=ReadString('Version Info','KQSys.exe','');
      SQLCount :=ReadInteger('SQL','SQLCount',15);
      WebStr   :=ReadString('WWW','URL','');
    end;
  nDownFileCount:=DownList.Count;
  NetVer:=StrToFloat(Copy(NetVerStr,1,3));
  DeleteFile(WinPath+'NetUpdate.ini');
end;

procedure TFrm_Main.DispPanelVer;
begin
  if FileExists('KQSys.exe') then
    begin
      LocalVerStr:=GetFileVerStr('KQSys.exe');
      if Pos('65535',LocalVerStr)>0 then Panel1.Caption:=Format('从旧版本升级到新版本( %S )',[NetVerStr])
      else  Panel1.Caption:=Format('从旧版本( %S )升级到新版本( %S )',[LocalVerStr,NetVerStr]);
    end
  else Panel1.Caption:=Format('从旧版本升级到新版本( %S )',[NetVerStr]);
end;


procedure TFrm_Main.DownAFile(aName: String);
var
  aURL, aFile: string;
  LStr:string;
begin
  aURL := MyURL+aName;  //下载地址
  aFile := GetURLFileName(aURL); //得到文件名，例如"KQSys.exe"
  if (aFile='KQSys.exe') or (aFile='Update.exe') then
    begin
      if FileExists(aFile) then
        begin
          if GetFileVerStr(aFile)=NetVerStr then  //说明是最新的版本了
            begin
               case Application.MessageBox(PChar('系统已经是最新版本了，是否还要升级？'),PChar('系统提示'),MB_YESNO+MB_ICONQUESTION) of
                  IDYes:
                    begin
                      aHint:=False;
                      NoRunSQL:=True;
                      MyDownLoad(aURL, aFile, False); //覆盖
                    end;
                  IDNo: Exit; //取消
               end;
            end
          else if Pos('65535',GetFileVerStr(aFile))>0 then
            begin
              case Application.MessageBox(PChar('系统检查到原先文件未下载完毕，是否续传？'),PChar('系统提示'),MB_YESNOCANCEL+MB_ICONQUESTION) of
                  IDYes:
                    begin
                      aHint:=False;
                      MyDownLoad(aURL, aFile, True); //续传
                    end;
                  IDNo:
                    begin
                      MyDownLoad(aURL, aFile, False); //覆盖
                    end;
                  IDCancel: Exit; //取消
              end;
            end
          else if StrToFloat(Copy(GetFileVerStr(aFile),1,3))<NetVer then //说明是旧版本的
            begin
              MyDownLoad(aURL, aFile, False); //建立新文件下载
            end;
        end
      else
        begin
          MyDownLoad(aURL, aFile, False); //建立新文件下载
        end;
    end
  else
    begin
      MyDownLoad(aURL, aFile, False); //建立新文件下载
    end;
end;

procedure TFrm_Main.WriteErrLog(ErrStr:String);
var
  LogFilename: String;
  LogFile: TextFile;
begin
  LogFilename:=ExtractFilePath(ParamStr(0))+'Error.Log';
  AssignFile(LogFile, LogFilename);
  if FileExists(LogFilename) then Append(LogFile)
  else Rewrite(LogFile);
  Writeln(Logfile,DateTimeToStr(now)+': '+ErrStr);
  CloseFile(LogFile);
end;

procedure TFrm_Main.FormDestroy(Sender: TObject);
begin
  DownList.Free;
  ExeList.Free;
  Frm_Main:=nil;
end;

end.