xeduser.pas

一个桌旁室收费系统

unit XEDUSER;

interface
uses
  Windows, WinSpool, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Printers, BDE, ShellAPI, Math, StdCtrls, ExtCtrls, DBTables, DB, DBGrids, Registry;

const
  SysFile = 'D:\PAS\XED.INT';
  MyName = '';
  MyCode = '';
  MyPage = '';
type
  WatchColor = array[1..10] of TColor;
  TCPUID = array[1..4] of Longint;
  TVChar = array[0..11] of char;

const PassKey: string = 'Present';
var
  Systemor: Boolean = false;
  KeyPath: string = 'SoftWare\MicroSoft\Windows\CurrentVersion\';
  MainCap: string = '';
  SellName: string = '';
  SellCode: string = '';
  ClassStr: string = '';
  OldCoder: string = '';
  HardCode: string = '';
  ShowName: string = '';
  Name1: string = '计时表';
  Name2: string = '雄棋娱乐室';

  Registed: Boolean = False;
  CompRate: Byte = 10;
  CompName: string = '';
  ShopExec: string = '';
  CanEdit: Boolean = True;
  FirstUse: Boolean = True;
  OpenFile: Boolean = False;
  MakeNews: Boolean = False;
  BT: TDatetime = 0;
  RegPass, CurPass: string;
  DeskBMP, IniPath: string;
  CoName, CoTele, CoPage: string;
  Truant: Word;
var
  Grade: Integer;
  SX, SY: Word;
  MSt0, MSt: Word;
  GDate1, GDate2: TDate;
  PrHandle: DWord;
  
function FormatCode(S: String): String;
procedure Run(S: string);
function NewCom(var Comb: TComboBox): Boolean;
function CanExit: Boolean;
function HasField(T: TQuery; S: string): Boolean;
procedure SetRatio(X, Y: Word);
function GetDrive: string;
procedure SetAlias(NameStr, Dirstr: string);
procedure PackTable(Name: string);
procedure PickStr(P: TColumn; tb: TTable; S: string);
procedure CloseMDI(H: THandle);
procedure ShowTime(M: TImage);

function PrintName: PChar;
function PrintHandle: Cardinal;
function SetLocPrint(Size, Wide, Leng: Integer; spOrder: Boolean): Boolean;
function AbortPrint: Boolean;
function PrintState: integer;
function ENumPrint(S: TStrings): Boolean;
function CopyFiles(H: integer; F1, F2: string): Boolean;
function GetCPUID: TCPUID;
function GetCPUVendor: TVChar;
function FileVersion(S: string): string;
function DiskID(Drive: PChar): string;
function OutofDate: Boolean;
function EncodeStr(S: string): string;
procedure LoadSite(Hnd: THandle; Key: string);
procedure SaveSite(Hnd: THandle; Key: string);
function GetPYStr(HZStr: WideString): string;
procedure RedrawForm(Sender: TObject);
function Cost(P1, P2, T1, T2: TTime): Real;

implementation

function Cost(P1, P2, T1, T2: TTime): Real;
Begin
//P1, P2: 实际时间; T1, T2: 基准时间

  If P1 < 4/24 then P1 := P1 + 1;
  If P2 < 4/24 then P2 := P2 + 1;
  If P1 > P2 Then Begin
    Showmessage('非法的时间记录,请修改出入时间');
    Result := 0;
    Exit;
  End Else Begin
    If T2 = 0 Then T2 := T1 + 1;
    If (P1 < T1) Then P1 := T1;
    If (P2 > T2) Then P2 := T2;
    If P1 > P2 Then Result := 0
    Else Result := 24 * (P2 - P1);// 小时数
  End;
//  Showmessage(Datetimetostr(P1)+'-'+Datetimetostr(P2)+', on:'+timetostr(T1)+'-'+timetostr(T2)
//  +' is hour: '+ floattostr(result));
End;

function FormatCode(S: String): String;
var
  I: Integer;
Begin
  Result := '';
  For i := 1 To Length(S) Do Begin
    if ((I + 3) mod 4 = 0) and (I > 1) and (S[I] <> '-') then Result := Result + '-' + S[I]
      else Result := Result + S[I];
  End;
End;

function GetDrive: string;
var
  drives: set of 0..25;
  drive: integer;
begin
  Result := '';
  DWORD(drives) := Windows.GetLogicalDrives;
  for drive := 0 to 25 do
    if drive in drives then
      Result := Result + Chr(drive + Ord('A'));
end;

procedure SetRatio(X, Y: Word);
var
  DM: TDeviceMode;
begin
  ENumDisplaySettings(nil, 0, DM);
  DM.dmFields := dm_pelswidth or dm_pelsheight;
  DM.dmPelsWidth := X;
  DM.dmPelsHeight := Y;
  ChangeDisplaySettings(DM, 1);
end;

procedure Run(S: string);
var P: array[0..79] of char;
begin
  StrPCopy(P, S);
  WinExec(P, 1);
end;

function NewCom(var Comb: TComboBox): Boolean;
var I: Integer;
  NewComb: Boolean;
begin
  NewComb := True;
  for i := 0 to Comb.Items.Count - 1 do
    if Comb.Text = Comb.Items[i] then
    begin
      NewComb := False;
      Break;
    end;
  if NewComb then Comb.items.Add(Comb.Text);
  NewCom := NewComb;
end;

function CanExit: Boolean;
begin
  CanExit := True;
end;

function HasField(T: TQuery; S: string): Boolean;
var I: Word;
begin
  T.Open;
  for I := 1 to T.FieldCount - 1 do
    if T.Fields[I].FieldName = S then begin
      Result := True;
      Exit;
    end;
  Result := False;
end;

procedure SetAlias(NameStr, Dirstr: string);
var
  P: string;
begin
  P := Copy(Dirstr, 1, 2);
  with Session do begin
    if IsAlias(NameStr) then
      DeleteAlias(NameStr);
    Close;
    if DRIVE_REMOTE = GetDriveType(PChar(P)) then begin
      NetFileDir := DirStr;
      Showmessage('设置指定的网络驱动器作为系统数据库路径');
    end else NetFileDir := '';
    ConfigMode := cmSession;
    AddStandardAlias(NameStr, Dirstr, 'PARADOX');
    Open;
  end;
end;

procedure PackTable(Name: string);
//DbiPackTable(Table1.DBHandle, Table1.Handle, nil, szdBASE, True);
var
  Props: CURProps;
  hDb: hDBIDb;
  TableDesc: CRTblDesc;
  Table: TTable;
begin
  Table := TTable.Create(nil);
  Table.Exclusive := True;
  Name := ExpandFileName(Name);
  Table.TableName := Name;
  try
    Table.Open;
    HDb := Table.Database.Handle;
    DbiGetCursorProps(Table.Handle, Props);
    Table.Close;
    if (Props.szTableType = szPARADOX) then begin
      FillChar(TableDesc, sizeof(TableDesc), 0);
      StrPCopy(TableDesc.szTblName, Table.TableName);
      StrPCopy(TableDesc.szTblType, Props.szTableType);
      TableDesc.bPack := True;
      DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False);
    end;
  except
    Showmessage('因故无法整理数据库：' + Name);
  end;
  Table.Free;
end;

procedure PickStr(P: TColumn; tb: TTable; S: string);
var
  Opened: Boolean;
begin
  Opened := tb.Active;
  tb.Open;
  tb.First;
  tb.DisableControls;
  P.PickList.Clear;
  while not tb.eof do begin
    P.PickList.Add(tb[S]);
    tb.Next;
  end;
  tb.Active := Opened;
  tb.enableControls;
end;

function GetPass(S: string): Real;
var
  I: Word;
  T: Real;
begin
  T := 1.2345678;
  for i := 1 to Length(S) do T := T * Byte(S[I]);
  Result := T;
end;


procedure CloseMDI(H: THandle);
begin
  SendMessage(application.mainform.ClientHandle, WM_MDIDESTROY, H, 0);
end;

procedure ShowTime(M: TImage);
const
  PRuler1 = clWhite; //刻度1
  PRuler2 = clBlue; //刻度2

  PHour = clWhite;
  PMin = clWhite;
  PSec = clRed; //秒色
  PDing1 = clYellow; //丁色
  PDing2 = clYellow;

  Word1 = clGreen; //字1
  Word2 = clFuchsia; //字2

var
  a: Word;
  b: Word;
  R0: Word;
  P1, P2, P3, P4: TPoint;
  Angle: Real;
  Hour, Minute, Sec, MSec: Word;
  I: Word;
  X, Y: Word;
  Delt: Word;
  Delt21: Word;
  Delt22: Word;
  TM: TTime;
  C: TCanvas;
  IMG: TImage;
  Lab1: TLabel;
  ss, SinK, CosK: Word;
  K: Real;

  procedure Site(H, W: Word; Angle: Real; var P1, P2: TPoint);
  var
    S1, S2, S3, S4: Real;
  begin
    if not M.Visible then exit;
    Angle := Angle - pi / 2;
    S1 := H * Sin(Angle);
    S2 := H * Cos(Angle);
    S3 := W * Sin(Angle);
    S4 := W * Cos(Angle);

    P1.X := Round(S2 - S3) + a;
    P1.Y := Round(S1 + S4) + b;
    P2.X := Round(S2 + S3) + a;
    P2.Y := Round(S1 - S4) + b;
  end;

begin
  TM := Now;
  DecodeTime(Now, Hour, Minute, Sec, MSec);
  MST := MSec div 500;
  if MST = MST0 then Begin
    MST0 := MST + 1;
    Exit;
  End;
  MST0 := MST;

  a := M.Width div 2;
  b := M.Height div 2;
  if a < b then r0 := a else r0 := b;

  IMG := TImage.Create(nil);

  IMG.Width := M.Width;
  IMG.Height := M.Height;

  C := IMG.Canvas;

  C.Brush.Color := clGreen;
  C.Pen.Color := clRed;

  with IMG.ClientRect do // 画边框
    C.Rectangle(Left, Top, Right, Bottom);

  C.Pen.Width := 5;
  Delt := R0 * 9 div 100;
  C.Pen.Color := $DEDEDE; // 画外圆
  C.Brush.Color := c.pen.Color; // 画指针
  C.Ellipse(Delt, Delt, a * 2 - Delt, b * 2 - Delt);

  C.Brush.Color := clGray; // 画底色
  C.Pen.Color := clGreen;
  Delt := R0 * 10 div 100;
  C.Ellipse(Delt, Delt, a * 2 - Delt, b * 2 - Delt);

  C.Pen.Width := 1;

  Delt21 := R0 * 30 div 1000; // 画刻度
  Delt22 := R0 * 50 div 1000;

  SS := Sec + trunc(msec div 500 / 2); //秒针角度
  for i := 0 to 59 do begin
    if i mod 5 > 0 then Delt := Delt21 else Delt := Delt22;

    Angle := (i / 30 + i div 15 / 2) * pi;

    if (SS = i) then begin
      C.Pen.Color := PRuler1; // 画刻度
      C.Brush.Color := PRuler1;
    end else begin
      C.Pen.Color := PRuler2; // 画刻度
      C.Brush.Color := PRuler2;
    end;

    K := Arctan(tan(Angle) * a / b) + (i + 45) div 15 * pi / 2;
    CosK := Round((a - R0 * 20 div 100) * Cos(k));
    SinK := Round((b - R0 * 20 div 100) * Sin(k));
    X := a + CosK;
    y := b + SinK;
    C.Ellipse(X - Delt, Y - Delt, X + Delt, Y + Delt);
  end;

  C.Brush.Color := clGray; //字底色

  Lab1 := TLabel.Create(nil);
  Lab1.Caption := Name1;
  Lab1.Font.Name := 'MS Sans Serif';
  Lab1.Font.Color := clRed;
  Lab1.Font.Style := [fsBold];
  Lab1.Font.Height := R0 * 12 div 50;

  C.Font := Lab1.Font;
  C.TextOut(a - Lab1.Width div 2, B * 5 div 10, Lab1.Caption);
  Lab1 := TLabel.Create(nil);
  Lab1.Font.Height := R0 * 15 div 50;
  Lab1.Caption := Name2;
  Lab1.Font.Name := 'MS Sans Serif';
  Lab1.Font.Color := clYellow;
  Lab1.Font.Style := [fsBold];
  Lab1.Font.Height := R0 * 18 div 100;

  C.Font := Lab1.Font;
  C.TextOut(a - Lab1.Width div 2, B * 14 div 10, Lab1.Caption);
  Lab1.Free;

  C.Brush.Color := PHour; // 画指针
  C.Pen.Color := C.Brush.Color;
  Angle := TM * 4 * Pi;
  Site(R0 * 45 div 100, R0 * 4 div 100, Angle, P1, P2); // 时针