tinyprogress.pas

一个Delphi写的跟考勤机门禁机收款机的接品软件源码

unit TinyProgress;

interface
uses
  Windows, Messages, Commctrl, SysUtils;

const
  IDD_PROGRESS    = 101;
  IDC_PROGRESS    = 1000;
  IDC_ANIMATE     = 1001;
  IDC_MSG1        = 1002;
  IDC_MSG2        = 1003;
  IDC_CLOSE       = 1004;
  CM_BASE         = $B000;
  CM_TEXTCHANGED  = CM_BASE+18;
  cctrl           = 'comctl32.dll';
  ShellDllName    = 'shell32.dll';

resourcestring
  msg_information='提示';
  msg_infor='提示';
  msg_confirm='请确认';
  msg_warning='警告';
  msg_error='错误';
  msg_reading_first_block_records='正在读取第一批数据,大约需 %d 秒.';
  msg_saving_record_progress='正在保存第 %d/%d 条记录...';
  msg_record_verified_error='记录校验错误, 是否保存? ';
  msg_are_you_continue='是否继续接收? ';
  msg_are_you_sure_to_abort='您确实要中止数据接收吗?';

var
  bQuitProgress: Boolean;
  hProgDlg: HWND;

function CreateProcessDlg(hWndParent: HWND): HWND;
procedure ShowProcessDlg(hWnd: HWND);
procedure CloseDialog(hWnd: HWND);
procedure UpdateMsgText(ID: Integer; const Str: string);
procedure ProgSetStep(Id: Integer; Value: Integer);
procedure ProgStepIt(Id: Integer);
procedure ProgSetRange(Id: Integer; AMin, AMax: Integer);
procedure ProgSetPosition(Id: Integer; Value: Integer);
procedure PlayAnimate(Id: Integer);

implementation
{$R *.res}
var
  F32BitMode: Boolean;
  ShellModule: THandle;

procedure UpdateMsgText(ID: Integer; const Str: string);
begin
  SetDlgItemText(hProgDlg, ID, PChar(Str));
end;

procedure SetProgCaption(const Str: string);
begin
  SendMessage(hProgDlg, WM_SETTEXT, 0, Longint(PChar(Str)));
  SendMessage(hProgDlg, CM_TEXTCHANGED, 0, 0);
end;

function GetShellModule: THandle;
begin
  if ShellModule=0 then
  begin
    ShellModule := SafeLoadLibrary(ShellDllName);
    if ShellModule<=HINSTANCE_ERROR then
      ShellModule := 0;
  end;
  Result := ShellModule;
end;

procedure PlayAnimate(Id: Integer);
var
  hAnimate: HWND;
begin
  hAnimate := GetDlgItem(hProgDlg, Id);
  if hAnimate<>0 then
  begin
    SendMessage(hAnimate, ACM_OPEN, GetShellModule, 160);
    SendMessage(hAnimate, ACM_PLAY, -1, MakeLong(Word(0-1), Word(34-1)));
  end;
end;

procedure ProgSetRange(Id: Integer; AMin, AMax: Integer);
var
  hProg: HWND;
begin
  hProg := GetDlgItem(hProgDlg, Id);
  if hProg<>0 then
  begin
    if F32BitMode then
      SendMessage(hProg, PBM_SETRANGE32, AMin, AMax)
    else
      SendMessage(hProg, PBM_SETRANGE, 0, MakeLong(AMin, AMax));
  end;
end;

procedure ProgSetStep(Id: Integer; Value: Integer);
var
  hProg: HWND;
begin
  hProg := GetDlgItem(hProgDlg, Id);
  if hProg<>0 then
    SendMessage(hProg, PBM_SETSTEP, Value, 0);
end;

procedure ProgSetPosition(Id: Integer; Value: Integer);
var
  hProg: HWND;
begin
  hProg := GetDlgItem(hProgDlg, Id);
  if hProg<>0 then
    SendMessage(hProg, PBM_SETPOS, Value, 0)
end;

procedure ProgStepIt(Id: Integer);
var
  hProg: HWND;
begin
  hProg := GetDlgItem(hProgDlg, Id);
  if hProg<>0 then
    SendMessage(hProg, PBM_STEPIT, 0, 0);
end;

function MainDialogProc(DlgWin: hWnd;
  DlgMessage: UINT;
  DlgWParam: WPARAM;
  DlgLParam: LPARAM): Integer; stdcall;
//var
//  MyIcon: HICON;
begin
  Result := 0;
  case DlgMessage of
    WM_INITDIALOG:
      begin
        //不显示图标
//        MyIcon := LoadIcon(hInstance, 'MAINICON');
//        SetClassLONG(DlgWin, GCL_HICON, MyIcon);
      end;
    WM_CLOSE:
      begin
        bQuitProgress := True;
        Exit;
      end;
    WM_COMMAND:
      case LOWORD(DlgWParam) of
        IDC_CLOSE:
          begin
            bQuitProgress := True;
            Exit;
          end;
      end;
  end;
end;

procedure InitCommonControls; external cctrl name'InitCommonControls';

function InitCommonControl(CC: Integer): Boolean;
var
  ICC: TInitCommonControlsEx;
begin
  ICC.dwSize := SizeOf(TInitCommonControlsEx);
  ICC.dwICC := CC;
  Result := InitCommonControlsEx(ICC);
  if not Result then InitCommonControls;
end;

function CreateProcessDlg(hWndParent: HWND): HWND;
begin
  F32BitMode := InitCommonControl(ICC_PROGRESS_CLASS);
  Result := CreateDialog(hInstance, PChar(IDD_PROGRESS), hWndParent, @MainDialogProc);
  hProgDlg := Result;
  bQuitProgress := False;
end;

procedure ShowProcessDlg(hWnd: HWND);
begin
  ShowWindow(hWnd, SW_SHOW);
end;

procedure CloseDialog(hWnd: HWND);
begin
  DestroyWindow(hWnd);
end;

initialization

finalization
  if ShellModule<>0 then FreeLibrary(ShellModule);

end.