Прогрессбар в заставке при копировании файла при загрузке программы - PullRequest
Новая
       35

Прогрессбар в заставке при копировании файла при загрузке программы

0 голосов
/ 26 августа 2010

ОК, вот полный код для Splashbar.pas, все еще есть три индикатора выполнения, так как я хочу посмотреть, как они выглядят, прежде чем выбрать один Он также включает некоторые вещи, которые отключены, так как я не могу заставить их работать. 

    unit Splashbar;

    interface

    uses ExtActns, Windows, SysUtils, Classes, Graphics, Forms, Controls, StdCtrls,
      Buttons, ExtCtrls, AdvProgr, ComCtrls, NetAPI32, SHFolder, WinInet, ActnList,
      AdvSmoothSplashScreen, AdvSmoothProgressBar, AdvSmoothProgressBarReg,
      UTCT1b, GIFImg;

    type
      TSplashBar1 = class(TForm)
        Bevel1: TBevel;
        ProgressBar1: TProgressBar;
        AdvProgress1: TAdvProgress;
        Timer1: TTimer;
        Label1: TLabel;
        AdvSmoothProgressBar1: TAdvSmoothProgressBar;
        ActionList1: TActionList;
        DatabaseCopy: TAction;
        procedure FormCreate(Sender: TObject);
        procedure DatabaseCopyExecute(Sender: TObject);
        procedure Timer1Timer(Sender: TObject);

      private  { Private declarations }
    {    procedure URLOnDownloadProgress  (Sender: TDownLoadURL;
             Progress, ProgressMax: Cardinal;
             StatusCode: TURLDownloadStatus;
             StatusText: String; var Cancel: Boolean) ; }

      public   { Public declarations }
        procedure OpenSplash;
        procedure ShowProgress;
        procedure CloseSplash;
      end;
      var
          SplashBar1 : TSplashBar1;
          dirpath: string;
          Total: Integer;
          Percent: Integer;

    implementation


    {$R *.dfm}


    function GetSpecialFolderPath(folder : integer) : string;
     const
       SHGFP_TYPE_CURRENT = 0;
     var
       path: array [0..MAX_PATH] of char;
     begin
       if SUCCEEDED(SHGetFolderPath(0,folder,0,SHGFP_TYPE_CURRENT,@path[0])) then
         Result := path
     else
         Result := '';
     end;

     function GetInetFile(const fileURL, FileName: String): boolean;
    const BufferSize = 1024;
    var
      hSession, hURL: HInternet;
      Buffer: array[1..BufferSize] of Byte;
      BufferLen: DWORD;
      f: File;
      sAppName: string;
    begin
    Result:=False;
    sAppName := ExtractFileName(Application.ExeName);
    hSession := InternetOpen(PChar(sAppName),
                    INTERNET_OPEN_TYPE_PRECONFIG,
                   nil, nil, 0);
    try
      hURL := InternetOpenURL(hSession,
                PChar(fileURL),
                nil,0,0,0);
      try
       AssignFile(f, FileName);
       Rewrite(f,1);
       repeat
        InternetReadFile(hURL, @Buffer,
                         SizeOf(Buffer), BufferLen);
        BlockWrite(f, Buffer, BufferLen)
       until BufferLen = 0;
       CloseFile(f);
       Result:=True;
      finally
       InternetCloseHandle(hURL)
      end
    finally
      InternetCloseHandle(hSession)
    end
    end;

    procedure TSplashBar1.FormCreate(Sender: TObject);
    begin
     Timer1.Enabled := True;
     DatabaseCopy.Execute;
     dirpath:=GetSpecialFolderPath($0023)+'\UTCT\';
    end;

  procedure TSplashBar1.DatabaseCopyExecute(Sender: TObject);
    var
      InternetFile,LocalFile: string;
    begin
    InternetFile:='http://160.14.20.20/log/Docs/test.xls';
    LocalFile:=(dirpath + 'test.xls');

    if GetInetFile(InternetFile,LocalFile)=True then
       Label1.Caption := 'Working...';
        //OnDownloadProgress := URLOnDownloadProgress;
      //else
      //  StatusBar1.Panels[2].Text := 'MTable Offline!' ;
        CopyFile(PChar(internetFile), PChar(LocalFile), False);
    end;

    procedure TSplashBar1.Timer1Timer(Sender: TObject);
    const  cnt: integer = 1;
    begin
      ProgressBar1.Position := cnt;
     if cnt = 1 then Label1.Caption := 'Waiting...'
    else
     if cnt = 100 then begin
     Label1.Caption := 'Done!';
      Timer1.Enabled := False;
     end
    else begin
    Label1.Caption := 'Working...';
           end;
    end;

    procedure TSplashBar1.OpenSplash;
    begin
      Label1.Caption := '';
      Show;
      Update;
    end;
    procedure TSplashBar1.CloseSplash;
    begin
      Close;
    end;

    procedure TSplashBar1.ShowProgress;
    var
      xs: integer;
    begin
    Label1.caption:='';
       Total := 1000;
          for xs := 1 to Total do
          begin
            Sleep(5);
            Percent := (xs * 100) div Total;
            Label1.caption := StringOfChar('|', Percent) + IntToStr(Percent) + '%';
            Label1.Repaint;

          end;
    end;

    end.


    //  {procedure TSplashBar1.URLOnDownloadProgress;
    // begin
    //   ProgressBar1.Max:= ProgressMax;
    //    ProgressBar1.Position:= Progress;
    //     AdvProgress1.Max:= ProgressMax;
    //      AdvProgress1.Position:= Progress;
    //      AdvSmoothProgressBar1.Position:= Progress;
    //
    //   end;  }

Ответы [ 2 ]

1 голос
/ 11 сентября 2010

Первая ошибка (W1056): Убедитесь, что

{$R *.RES} не введено дважды в вашем dpr (Project | View Source)

Secondошибка (H2077): Где-то еще в вашем коде, не может помочь с этим

Третья ошибка (W1019): Вы должны поставить 

var
  X: integer

сразу после 

procedure TSplashBar1.ShowProgress;

Кажется, вы определили X где-то, кроме процедуры, о которой свидетельствует ошибка переменной управления циклом.

0 голосов
/ 27 августа 2010

Включили ли вы модуль TSplashBar в условие вашего использования для файла .dpr, и определяет ли он глобальную переменную SplashBar?

...