xeduser.pas

一个桌球室收费系统

  Site(R0 * 10 div 100, R0 * 5 div 100, Angle + Pi, P3, P4);
  C.Polygon([P1, P2, P3, P4]);

  C.Brush.Color := PMin;
  C.Pen.Color := C.Brush.Color;
  Angle := (TM - Hour) * 48 * Pi;
  Site(R0 * 60 div 100, R0 * 3 div 100, Angle, P1, P2); // 分针
  Site(R0 * 12 div 100, R0 * 4 div 100, Angle + Pi, P3, P4);
  C.Polygon([P1, P2, P3, P4]);

  C.Brush.Color := PSec;
  C.Pen.Color := C.Brush.Color;
  Angle := (Sec + msec div 500 / 2) * Pi / 30;
  Site(R0 * 75 div 100, R0 * 1 div 100, Angle, P1, P2); // 秒针
  Site(R0 * 15 div 100, R0 * 2 div 100, Angle + Pi, P3, P4);
  C.Polygon([P1, P2, P3, P4]);

  C.Brush.Color := clBlack;
  C.Pen.Color := C.Brush.Color;
  Delt := R0 * 5 div 100;
  C.Ellipse(a - Delt, b - Delt, a + Delt, b + Delt);
  M.Picture := IMG.Picture;
  IMG.Free;
end;

function ENumPrint(S: TStrings): Boolean;
var
  Buffer: array[1..1200] of char;
  Reads, Num: DWord;
  PName: _PRINTER_INFO_1;
  I: Word;
begin
  Result := EnumPrinters(PRINTER_ENUM_LOCAL, nil, 1, @Buffer, 1000, Reads, Num);
  if not Result then exit;
  S.Clear;
  for i := 0 to Num - 1 do begin
    Move(Buffer[i * Sizeof(PName) + 1], PName, Sizeof(PName));
    S.Add(PName.pName);
  end;
end;

function PrintName;
var
  Buffer: array[1..1200] of char;
  Reads, Num: DWord;
  PName: _PRINTER_INFO_1;
begin
  EnumPrinters(PRINTER_ENUM_DEFAULT, nil, 1, @Buffer, 1000, Reads, Num);
  Move(Buffer[1], PName, Sizeof(PName));
  Result := PName.pName;
end;

function PrintHandle: Cardinal;
var
  Hdl: Cardinal;
begin
  if OpenPrinter(PrintName, Hdl, nil) then
    Result := Hdl else Result := 0;
end;

function SetLocPrint(Size, Wide, Leng: Integer; spOrder: Boolean): Boolean;
type
  TPaperName = array[1..64] of Char;
  TPaperNames = array[0..0] of TPaperName;
  PPaperNames = ^TPaperNames;
var
  Dev, Drv, Port: array[1..128] of Char;
  hDMode: THandle;
  pDMode: PDevMode;
begin
  Printer.PrinterIndex := Printer.PrinterIndex;
  Printer.GetPrinter(@Dev, @Drv, @Port, hDMode);
  if hDMode <> 0 then begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then begin
      if spOrder then
        pDMode.dmOrientation := DMORIENT_PORTRAIT
      else
        pDMode.dmOrientation := DMORIENT_LANDSCAPE;
      pDMode.dmPaperSize := Size;
      pDMode.dmPaperLength := Leng;
      pDMode.dmPaperWidth := Wide;
      pDMode.dmMediaType := 1;
      pDMode.dmFields := pDMode.dmFields
        or dm_Orientation
        or dm_PaperSize
        or dm_PaperLength
        or dm_PaperWidth
        or dm_MediaType;
    end;
    GlobalUnlock(hDMode);
  end;
  Printer.PrinterIndex := Printer.PrinterIndex;
  Result := True;
end;

function AbortPrint;
begin
  Result := WinSpool.SetPrinter(PrHandle, 0, nil, PRINTER_CONTROL_PURGE);
end;

function PrintState: Integer;
var
  S3: cardinal;
  P1: _PRINTER_INFO_2;
  DV: Devmode;
  Buffer: array[1..1200] of char;
  ST: Cardinal;
  S: string;
begin
  S3 := 1000;
  if not GetPrinter(PrHandle, 2, @Buffer[1], S3, @S3) then
  begin
    PrintState := 0;
    Exit;
  end;
  Move(Buffer[1], P1, Sizeof(P1));
  DV := P1.pDevMode^;
  if dv.dmSize = 0 then ;
  ST := P1.Status;
  case ST of
    PRINTER_STATUS_BUSY: S := 'AAAAA';
    PRINTER_STATUS_DOOR_OPEN: S := 'AAAAA';
    PRINTER_STATUS_ERROR: S := 'AAAAA';
    PRINTER_STATUS_INITIALIZING: S := 'AAAAA';
    PRINTER_STATUS_IO_ACTIVE: S := 'AAAAA';
    PRINTER_STATUS_MANUAL_FEED: S := 'AAAAA';
    PRINTER_STATUS_NO_TONER: S := 'AAAAA';
    PRINTER_STATUS_NOT_AVAILABLE: S := 'AAAAA';
    PRINTER_STATUS_OFFLINE: S := 'AAAAA';
    PRINTER_STATUS_OUT_OF_MEMORY: S := 'AAAAA';
    PRINTER_STATUS_OUTPUT_BIN_FULL: S := 'AAAAA';
    PRINTER_STATUS_PAGE_PUNT: S := 'AAAAA';
    PRINTER_STATUS_PAPER_JAM: S := 'AAAAA';
    PRINTER_STATUS_PAPER_OUT: S := 'AAAAA';
    PRINTER_STATUS_PAPER_PROBLEM: S := 'AAAAA';
    PRINTER_STATUS_PAUSED: S := 'AAAAA';
    PRINTER_STATUS_PENDING_DELETION: S := 'AAAAA';
    PRINTER_STATUS_PRINTING: S := 'AAAAA';
    PRINTER_STATUS_PROCESSING: S := 'AAAAA';
    PRINTER_STATUS_TONER_LOW: S := 'AAAAA';
//    PRINTER_STATUS_UNAVAILABLE        : S := 'AAAAA';
    PRINTER_STATUS_USER_INTERVENTION: S := 'AAAAA';
    PRINTER_STATUS_WAITING: S := 'AAAAA';
    PRINTER_STATUS_WARMING_UP: S := 'AAAAA';
  end;
  Showmessage(S);
  PrintState := ST;
end;

function CopyFiles(H: integer; F1, F2: string): Boolean;
var
  Path1, Path2: array[0..128] of Char;
  OPStruc: SHFileOpStruct;
begin
  fillchar(Path1, 129, 0);
  fillchar(Path2, 129, 0);
  StrpCopy(Path1, F1);
  StrpCopy(Path2, F2);
  with OpStruc do begin
    Wnd := 0;
    wFunc := FO_COPY;
    OpStruc.pFrom := @Path1;
    pTo := @Path2;
    fFlags := FOF_NOCONFIRMATION + FOF_NOCONFIRMMKDIR;
    fAnyOperationsAborted := False;
    hNameMappings := nil;
    lpszProgressTitle := 'aaa';
  end;

{    FOF_ALLOWUNDO :;
    FOF_CONFIRMMOUSE:;
    FOF_FILESONLY:;
    FOF_MULTIDESTFILES:;
    FOF_NOCONFIRMATION:;
    FOF_NOCONFIRMMKDIR:;
    FOF_RENAMEONCOLLISION:;
    FOF_SILENT:;
    FOF_SIMPLEPROGRESS:;
    FOF_WANTMAPPINGHANDLE:;
}
  Result := ShFileOperation(OpStruc) = 0;
end;

function CPUID_Ready: Boolean;
asm
	PUSHFD			{direct access to flags no possible, only via stack}
	POP	EAX		{flags to EAX}
	MOV	EDX,EAX		{save current flags}
	XOR	EAX,$200000	{not ID bit}
	PUSH	EAX		{onto stack}
	POPFD			{from stack to flags, with not ID bit}
	PUSHFD			{back to stack}
	POP	EAX		{get back to EAX}
	XOR	EAX,EDX		{check if ID bit affected}
	JZ	@1		{no, CPUID not availavle}
	MOV	AL,True		{Result=True}
	@1:
end;

function GetCPUID: TCPUID;
asm
	PUSH	EBX         	{Save affected register}
	PUSH	EDI
	MOV	EDI,EAX     	{@Resukt}
	MOV	EAX,1
	DW	$A20F       	{CPUID Command}
	STOSD			{CPUID[1]}
	MOV	EAX,EBX
	STOSD               	{CPUID[2]}
	MOV	EAX,ECX
	STOSD               	{CPUID[3]}
	MOV	EAX,EDX
	STOSD         	{CPUID[4]}
	POP	EDI		{Restore registers}
	POP	EBX
end;

function GetCPUVendor: TVChar;
asm
	PUSH	EBX		{Save affected register}
	PUSH	EDI
	MOV	EDI,EAX	{@Result (TVChar)}
	MOV	EAX,0
	DW	$A20F		{CPUID Command}
	MOV	EAX,EBX
	XCHG	EBX,ECX 	{save ECX result}
	MOV	ECX,4
@1:	STOSB
	SHR	EAX,8
	LOOP	@1
	MOV	EAX,EDX
	MOV	ECX,4
@2:	STOSB
	SHR	EAX,8
	LOOP	@2
	MOV	EAX,EBX
	MOV	ECX,4
@3:	STOSB
	SHR	EAX,8
	LOOP	@3
	POP	EDI		{Restore registers}
	POP	EBX
end;

function FileVersion(S: string): string;
var
  L, Len: longword;
  Sz: Word;
  Buf: Pointer;
  Ver: ^TVSFixedFileInfo;
begin
  Sz := GetFileVersionInfoSize(PChar(S), L);
  if Sz = 0 then Result := '' else
  begin
    GetMem(Buf, Sz);
    GetFileVersionInfo(PChar(S), 0, Sz, Buf);
    VerQueryValue(Buf, '\', Pointer(Ver), Len);
    Result :=
      IntToStr(HIWORD(Ver.dwFileVersionMS)) + '.' +
      IntToStr(LOWORD(Ver.dwFileVersionMS)) + '.' +
      IntToStr(HIWORD(Ver.dwFileVersionLS)) + ' 编译次数：' +
      IntToStr(LOWORD(Ver.dwFileVersionLS));
    FreeMem(Buf, Sz);
  end;
end;

function DiskID(Drive: PChar): string;
var
  Tmp1, Tmp2: DWord;
  DW: DWord;
begin
  GetVolumeInformation(Drive,
    nil, 0, @DW, Tmp1, Tmp2, nil, 0);
  Result := IntToStr(DW);
end;

function EncodeStr(S: string): string;
var
  I: Integer;
  R: Word;
  P: string;
begin
  S := S + '123456789012345678';
  R := 4444;
  if R = 4444 then ;
  P := '';
  for I := 1 to 16 do begin
    if S[I] = #0 then S[I] := Chr(I + 65);
    R := Trunc(Sqrt((987 * Ord(S[I]) * 9)));
    R := R mod 1000;
    while R < 048 do R := R + 20 + I;
    while R > 090 do R := R - 20 - I;
    while R < 048 do R := R + 20 + I;
    P := P + Chr(R);
  end;
  Result := P;
end;

function OutofDate: Boolean;
const
  KeyName = 'FirstDate';
var
  Reg: TRegistry;
  P: string;
  i: Word;
  Date0: TDate;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKey_Local_Machine;
  Reg.OpenKey(KeyPath + PassKey, True);
  if Reg.ValueExists(KeyName) then begin
    P := Reg.ReadString(KeyName);
    for I := 1 to Length(P) do
      P[i] := Chr((ord(P[i]) - 25 - I) xor I);
    Date0 := StrToDate(P);
    Result := Date - Date0 > 40;
  end else begin
    P := FormatDateTime('yyyy-mm-dd', Date);
    for I := 1 to Length(P) do
      P[i] := Chr(ord(P[i]) xor I + 25 + I);
    Reg.WriteString(KeyName, P);
    Result := False;
  end;
  Reg.CloseKey;
  Reg.Free;
end;

procedure RedrawForm(Sender: TObject);
var
  H: THandle;
  DC: HDC;
begin
  H := FindWindow('Progman', nil);
  DC := GetWindowDC(H);
  Sendmessage(H, wm_EraseBkGnd, DC, 0);
  SendMessage(H, wm_Paint, DC, 0);
  RedrawWindow(H, nil, 0, RDW_ERASE or RDW_INVALIDATE
    or RDW_ALLCHILDREN);
  ReleaseDC(H, DC);
end;

procedure LoadSite(Hnd: THandle; Key: string);
var
  R: TRegistry;
  Place: TWindowPlacement;
begin
  R := TRegistry.Create;
  if R.OpenKey('SoftWare\X-Ware\' + Key, False) then begin
    R.ReadBinaryData('Position', Place, Sizeof(Place));
    SetWindowPlacement(Hnd, @Place);
    R.Free;
  end;
end;

procedure SaveSite(Hnd: THandle; Key: string);
var
  Place: TWindowPlacement;
  R: TRegistry;
begin
  R := TRegistry.Create;
  Place.length := Sizeof(Place);
  if not GetWindowPlacement(Hnd, @Place) then Exit;
  if R.OpenKey('SoftWare\X-Ware\' + Key, True) then begin
    R.WriteBinaryData('Position', Place, Sizeof(Place));
    R.Free;
  end;
end;

function GetPYStr(HZStr: WideString): string;
var
  S: string;
  I: Word;
  C: Char;
begin
  Result := '';
  for I := 1 to Length(HZStr) do begin
    S := HZStr[I];
    if Length(S) = 1 then C := S[1] else
      case WORD(S[1]) * 256 + Byte(S[2]) of
        $B0A1..$B0C4: C := 'A'; $B0C5..$B2C0: C := 'B';
        $B2C1..$B4ED: C := 'C'; $B4EE..$B6E9: C := 'D';
        $B6EA..$B7A1: C := 'E'; $B7A2..$B8C0: C := 'F';
        $B8C1..$B9FD: C := 'G'; $B9FE..$BBF6: C := 'H';
        $BBF7..$BFA5: C := 'J'; $BFA6..$C0AB: C := 'K';
        $C0AC..$C2E7: C := 'L'; $C2E8..$C4C2: C := 'M';
        $C4C3..$C5B5: C := 'N'; $C5B6..$C5BD: C := 'O';
        $C5BE..$C6D9: C := 'P'; $C6DA..$C8BA: C := 'Q';
        $C8BB..$C8F5: C := 'R'; $C8F6..$CBF9: C := 'S';
        $CBFA..$CDD9: C := 'T'; $CDDA..$CEF3: C := 'W';
        $CEF4..$D1B8: C := 'X'; $D1B9..$D4D0: C := 'Y';
        $D4D1..$D7F9: C := 'Z'; else C := '?';
      end;
    Result := Result + C;
  end;
end;

begin
  ShortDateFormat := 'yyyy-mm-dd';
  DateSeparator := '-';
  PrHandle := PrintHandle;
end.