在程序加载时复制文件时出现进度条

发布于 2024-09-16 06:05:29 字数 4681 浏览 10 评论 0原文

好的,这是 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;  }

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 : 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;  }

如果你对这篇内容有疑问,欢迎到本站社区发帖提问 参与讨论,获取更多帮助,或者扫码二维码加入 Web 技术交流群。

扫码二维码加入Web技术交流群

发布评论

需要 登录 才能够评论, 你可以免费 注册 一个本站的账号。

评论(2

肥爪爪 2024-09-23 06:05:29

第一个错误(W1056):
确保

{$R *.RES}
未在您的 dpr 中输入两次(项目|查看源代码)

第二个错误 (H2077):
代码中的其他地方无法解决

第三个错误(W1019):
你必须把

var
  X: integer

它放在

procedure TSplashBar1.ShowProgress;

You似乎已经在程序之外的其他地方定义了 X ,循环控制变量错误表明了这一点。

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.

番薯 2024-09-23 06:05:29

您是否在 .dpr 文件的“uses”子句中包含了 TSplashBar 的单位,并且它是否定义了全局 SplashBar 变量?

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

~没有更多了~
我们使用 Cookies 和其他技术来定制您的体验包括您的登录状态等。通过阅读我们的 隐私政策 了解更多相关信息。 单击 接受 或继续使用网站,即表示您同意使用 Cookies 和您的相关数据。
原文