xp设置拨号快捷方式:Delphi做的软件自动更新

Delphi做的软件自动更新

自己整理做的delphi自动更新程序，关键技术要感谢僵哥提供的获取版本号功能和startluck提供的批处理删除自身的功能，以及在网上查找资料所不能列举的各位好朋友！（本文章仅作为自己备忘所用）

unit UnitUpG;

interface

uses
  Forms,
  Windows,
  SysUtils,
  Classes,
  Controls,
  URLMON,
  SHellAPi,
  iniFiles,
  Tlhelp32;
  procedure UpGrade;
  procedure KillExe;
var
  SName:String;
  UpGradeB:Boolean;
type
  TLANGANDCODEPAGE=record
    wLanguage,wCodePage:Word;
end;
  PLANGANDCODEPAGE=^TLANGANDCODEPAGE;

type
  TUpDateThread=class(TThread)
  protected
    procedure Execute;override;
  end;

implementation

uses UNIT1;

function ShowVersion:String;
var
  VerInfo:PChar;
  lpTranslate:PLANGANDCODEPAGE;
  FileName:String;
  VerInfoSize,cbTranslate:DWORD;
  VerValueSize:DWORD;
  Data:String;

  VerFileV:PChar;
  lpFileVersion:string;
begin
  Result:='0.0.0.0';
  FileName:=Application.ExeName;
  VerInfoSize:=GetFileVersionInfoSize(PChar(FileName),VerInfoSize);
  if VerInfoSize>0 then
  begin
    VerInfo:=AllocMem(VerInfoSize);

    GetFileVersionInfo(PChar(FileName),0,VerInfoSize,VerInfo);

    VerQueryValue(VerInfo, PChar('/VarFileInfo/Translation'), Pointer(lpTranslate),cbTranslate);

    if cbTranslate<>0  then
    begin
      Data := format('/StringFileInfo/%.4x%.4x/FileVersion',[lpTranslate^.wLanguage,lpTranslate^.wCodePage]);

      VerQueryValue(VerInfo, PAnsiChar(data),Pointer(VerFileV), VerValueSize);
      if VerValueSize <> 0 then
      begin
        SetString(lpFileVersion,VerFileV,VerValueSize-1);
        Result:=lpFileVersion;
      end;
    end;
    FreeMem(VerInfo,VerInfoSize);
  end
  else begin
    Result:='0.0.0.0';
    Application.MessageBox('獲取文件版本信息時遇到致命錯誤，請重新打開軟件。','錯誤',MB_OK+MB_ICONSTOP);
    Application.Terminate;
  end;
end;


function KillTask(ExeFileName:string):integer;
const
  PROCESS_TERMINATE = $0001;
var
  ContinueLoop: BOOLean;
  FSnapshotHandle: THandle;
  FProcessEntry32: TProcessEntry32;
begin
  Result :=0;
  FSnapshotHandle := CreateToolhelp32Snapshot(TH32CS_SNAPPROCESS, 0);
  FProcessEntry32.dwSize := SizeOf(FProcessEntry32);
  ContinueLoop := Process32First(FSnapshotHandle, FProcessEntry32);
  while Integer(ContinueLoop) <> 0 do
  begin
    if ((UpperCase(ExtractFileName(FProcessEntry32.szExeFile)) =
      UpperCase(ExeFileName)) or (UpperCase(FProcessEntry32.szExeFile) =
      UpperCase(ExeFileName))) then
      Result := Integer(TerminateProcess(OpenProcess(PROCESS_TERMINATE,BOOL(0),
        FProcessEntry32.th32ProcessID),0));
      ContinueLoop := Process32Next(FSnapshotHandle, FProcessEntry32);
  end;
  CloseHandle(FSnapshotHandle);
end;

procedure TUpDateThread.Execute;
var
  FindUD:Boolean;
  inifile:TiniFile;
  i,Num:integer;
  DownFile,FSaveFile:String;
  Name,Path,CliVersion,SerVersion:String;
begin

  FindUD:=False;
  inifile:=TiniFile.Create(ExtractFilePath(Application.ExeName)+'UpDate.ini');
  Num:=StrToInt(inifile.ReadString('Program Number','Num',''));
  for i:=1 to Num do
  begin
    Name:=inifile.ReadString('session'+inttostr(i),'Name','');
    Path:=inifile.ReadString('session'+inttostr(i),'Path','');
    SerVersion:=inifile.ReadString('session'+inttostr(i),'Version','');
    CliVersion:=ShowVersion;

    if (Name=ExtractFileName(Application.ExeName)) and (CliVersion<>SerVersion) then
    begin
      FindUD:=True;
      DownFile:=Path+Name;
      SName:=DownFile;
      FSaveFile:=Application.ExeName;
      break;
    end;
  end;

  try
    DeleteFile(ExtractFilePath(Application.ExeName)+Name+'.old');
  except
    On E:Exception do
      Application.MessageBox('刪除舊版本失敗!','Error',MB_OK);
  end;

  if  FindUD then
  begin
    if Application.MessageBox('發現一個新版本的軟件，是否更新軟件?','軟件更新',MB_OKCancel)=mrOK then
    begin
      if Application.MessageBox('請選擇更新軟件的時間!現在更新點''yes'',關閉軟件時更新點''No''','軟件更新',MB_YESNO)=mrYes then
      begin
        Application.MessageBox('軟件更新期間請停止對軟件的操作，更新成功會自動重新打開程序！','軟件更新',MB_OK);
        Application.ProcessMessages;
        Screen.Cursor:=crHourGlass;
       
        try
          ReNameFile(FSaveFile,FSaveFile+'.old');
        except
          On E:Exception do
            Application.MessageBox('拷貝文件副本失敗!','Error',MB_OK);
        end;

        try
          URLDownloadToFile(nil,PAnsiChar(DownFile),PAnsiChar(FSaveFile),0,nil);

          ShellExecute(0, 'open', PChar(Name),PChar(ExtractFilePath(Application.ExeName)), nil, SW_SHOWNORMAL);
          KillTask(ExtractFileName(Application.ExeName));

        except
          On E:Exception do
          begin
            ReNameFile(FSaveFile+'.old',FSaveFile);
            Application.MessageBox('下載失敗!','Error',MB_OK);
            Screen.Cursor:=crDefault;
          end;
        end;
      end
      else begin
        UpGradeB:=True;
      end;
    end;
  end;
  iniFile.Free;
end;

procedure KillExe;
var
   BatchFile: TextFile;
   BatchFileName: string;
   ProcessInfo: TProcessInformation;
   StartUpInfo: TStartupInfo;
begin
   BatchFileName := ExtractFilePath(ParamStr(0)) + '_KillExe.bat';
   AssignFile(BatchFile, BatchFileName);
   Rewrite(BatchFile);

   Writeln(BatchFile, 'del "' + ParamStr(0) + '.old"');
   Writeln(BatchFile,
     'if exist "' + ParamStr(0) + '.old"' + ' goto try');
   Writeln(BatchFile, 'del %0');
   CloseFile(BatchFile);

   FillChar(StartUpInfo, SizeOf(StartUpInfo), $00);
   StartUpInfo.dwFlags := STARTF_USESHOWWINDOW;
   StartUpInfo.wShowWindow := SW_HIDE;
   if CreateProcess(nil, PChar(BatchFileName), nil, nil,
     False, IDLE_PRIORITY_CLASS, nil, nil, StartUpInfo,
     ProcessInfo) then
   begin
     CloseHandle(ProcessInfo.hThread);
     CloseHandle(ProcessInfo.hProcess);
   end;
end;

procedure UpGrade;
var
  FSaveFile,DownFile:String;
begin
  if UpGradeB then
  begin
    DownFile:=SName;
    FSaveFile:=Application.ExeName;
    Application.MessageBox('軟件更新期間請停止對軟件的操作！','軟件更新',mb_OK);
    Application.ProcessMessages;
    Screen.Cursor:=crHourGlass;
    try
      DeleteFile(FSaveFile+'.old');
    except
      On E:Exception do
        Application.MessageBox('刪除舊軟件失敗!','軟件更新',mb_OK);
    end;

    try
      ReNameFile(FSaveFile,FSaveFile+'.old');
    except
      On E:Exception do
        Application.MessageBox('拷貝文件副本失敗!','Error',mb_OK);
    end;

    try
      URLDownloadToFile(nil,PAnsiChar(DownFile),PAnsiChar(FSaveFile),0,nil);
      Screen.Cursor:=crdefault;

      Application.MessageBox('軟件更新成功!','軟件更新',mb_OK);
    except
      On E:Exception do
      begin
        ReNameFile(FSaveFile+'.old',FSaveFile);
        Application.MessageBox('更新軟件失敗，原軟件將恢復!','Error',mb_OK);
      end;
    end;

    try
      KillExe;
    except
      On E:Exception do
      begin
        Application.MessageBox('刪除舊軟件失敗！','Error',mb_OK);
      end;
    end;
  end;
end;


end.

2楼 k_harris 2011-11-08 22:41发表 [回复]

好像抄少了一句哦，需要在Rewrite(BatchFile);的后面加上如下一句Writeln(BatchFile, ':try');
对吧！

1楼 chinabady 2009-11-26 07:40发表 [回复]

谢谢，正准备做一个自动更新程序的东东。