开发者

Progressbar in splash while copying a file on program load

开发者 https://www.devze.com 2023-01-13 19:00 出处:网络
OK, here is the complete code for the Splashbar.pas, still have three progressbars, as I want to see what they look like before I choose one. It also includes some stuff that\'s disabled, as I can\'t

OK, here is the complete code for the Splashbar.pas, still have three progressbars, as I want to see what they look like before I choose one. It also includes some stuff that's disabled, as I can't get them to work.

    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 : in开发者_如何学Pythonteger) : 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;  }


First error (W1056): Make sure that

{$R *.RES} is not entered twice in your dpr (Project|View Source)

Second error (H2077): Somewhere else in your code, can't help with it

Third error (W1019): You have to put

var
  X: integer

right after

procedure TSplashBar1.ShowProgress;

You seem to have defined X somewhere other than the procedure, which the loop control variable error is indicating.


Did you include TSplashBar's unit in your .dpr file's 'uses' clause, and does it define a global SplashBar variable?

0

精彩评论

暂无评论...
验证码 换一张
取 消

关注公众号