xeduser.pas

特别方便的工具程序

  DV := P1.pDevMode^; //这里好多可以设置
  with DV do begin
    dmDriverExtra := 0;
    spSize := dmPaperSize;
    spOrder := dmOrientation = DMORIENT_PORTRAIT;
    Wide := dmPaperWidth;
    Leng := dmPaperLength;
  end;
  Result := True;
end;

function SetSysPrint(spSize, Wide, Leng: Integer; spOrder: Boolean): Boolean;
var
  S3: Cardinal;
  P1: _PRINTER_INFO_2;
  DV: Devmode;
  Buffer: array[1..1200] of Byte;
begin
  S3 := 1000;
  if not GetPrinter(PrHandle, 2, @Buffer[1], S3, @S3) then
  begin
    Result := False;
    Exit;
  end;
  Move(Buffer[1], P1, Sizeof(P1));
  DV := P1.pDevMode^; //这里好多可以设置
  with DV do begin
    dmDriverExtra := 0;
    dmPaperSize := spSize;
    dmPaperWidth := Wide;
    dmPaperLength := Leng;
    dmDitherType := DMDITHER_NONE;
    if spOrder then
      dmOrientation := DMORIENT_PORTRAIT
    else
      dmOrientation := DMORIENT_LANDSCAPE;
    dmFields := dmFields or dm_Orientation
      or dm_DitherType or dm_PaperSize;
//             or 67134991;//FFFF状态
    dmFields := 67134979; //初试状态
    dmFields := 67134991;
  end;
  P1.pDevMode^ := DV;
  Result := WinSpool.SetPrinter(PrHandle, 2, @Buffer[1], 0);
  if Result then Beep;
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 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;

function HasRegister: Boolean;
var
  Reg: TRegistry;
begin
  Reg := TRegistry.Create;
  Reg.RootKey := HKey_Local_Machine;
  Reg.OpenKey(KeyPath + PassKey, False);
  RegPass := Copy(Reg.ReadString('PassWord'), 1, 16);
  if RegPass = '' then Result := False else
    Result := RegPass = EncodeStr(DiskID('C:\'));
  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(Form: TForm; Key: string);
var
  R: TRegistry;
  Place: TWindowPlacement;
  Hnd: THandle;
  SC: Word;
begin
  Hnd := Form.Handle;
  R := TRegistry.Create;
  if R.OpenKey('SoftWare\X-Ware\' + Key, False) then begin
    R.ReadBinaryData('Position', Place, Sizeof(Place));
    SC := Place.showCmd;
    Place.showCmd := 0;
    SetWindowPlacement(Hnd, @Place);
    if SC = 3 then Form.WindowState := wsMaximized;
  end;
  R.Free;
end;

procedure SaveSite(Form: TForm; Key: string);
var
  Place: TWindowPlacement;
  R: TRegistry;
begin
  Place.length := Sizeof(Place);
  if not GetWindowPlacement(Form.Handle, @Place) then Exit;
  R := TRegistry.Create;
  if R.OpenKey('SoftWare\X-Ware\' + Key, True) then begin
    R.WriteBinaryData('Position', Place, Sizeof(Place));
  end;
  R.Free;
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;

function CoinStr(SumCoin: Real): string;
const
  UY: wideString = '分角元十百千万十';
  UD: wideString = '零壹贰叁肆伍陆柒捌玖';
var
  S, Y: string;
  i, j, L: integer;
begin
  Y := IntToStr(round(SumCoin * 100));
  S := '整';
  L := Length(Y);
  for i := L downto 1 do
  begin
    j := StrToInt(Y[I]);
    S := UD[j + 1] + '' + UY[L - I + 1] + S;
  end;
  S := FormatFloat('"总计金额："0.00" 元"', SumCoin) + ',(大写):' + S;
  Result := S;
end;

function OICQ(const FName: string = 'C:\Program Files\Tencent\Dat\OICQ2000.CFG'): string;
var
  I, F1, Size, Len: Integer;
  Buffer: array of Byte;
begin
  f1 := FileOpen(FName, fmOpenRead);
  Size := FileSeek(f1, 0, 2); //文件长度
  SetLength(Buffer, Size);
  FileSeek(f1, 0, 0);
  FileRead(f1, Buffer[1], Size);
  FileClose(f1);
  Len := Buffer[5];
  for i := 0 to Len do Buffer[i + 9] := not Buffer[i + 9];
  Result := PChar(@Buffer[9]);
  SetLength(Buffer, 0);
end;

procedure DeskShort(PathName: string; LinkName: WideString);
var
  MYObject: IUnknown;
  SLink: IShellLink;
  PFile: IPersistFile;
  P_IDL: PItemIDList;
  DeskTop: array[0..MAX_PATH] of Char;
begin
  MYObject := CreateComObject(CLSID_ShellLink);
  SLink := MYObject as IShellLink;

  // 以下获取 DeskTop 目录
  SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, P_IDL);
  SHGetPathFromIDList(P_IDL, DeskTop);
  LinkName := '\' + LinkName;
  LinkName := DeskTop + LinkName;

  SLink.SetPath(pChar(PathName));
  SLink.SetWorkingDirectory(pChar(ExtractFileDir(PathName)));

  PFile := MYObject as IPersistFile;
  PFile.Save(pWChar(LinkName), True);
end;

function GetQuick(Input: string): string;
var
  LinkName: string;
  PathName: PChar;
  MYObject: IUnknown;
  SLink: IShellLink;
  PFile: IPersistFile;
//  P_IDL: PItemIDList;
//  DeskTop: array[0..MAX_PATH] of Char;
  AAA2: WIN32_FIND_DATA;
begin
  MYObject := CreateComObject(CLSID_ShellLink);
  // 以下获取 DeskTop 目录
  LinkName := Input;
  PFile := (MYObject) as IPersistFile;
  PFile.Load(PWideChar(WideString(LinkName)), S_OK);

  SLink := IShellLink(MYObject);
  GetMem(PathName, 255);
  SLink.GetPath(PathName, 255, AAA2, SLGP_UNCPRIORITY);
  Result := PathName;
//  Result.Add('目标名称：'#13#10 + PathName);
//  SLink.GetWorkingDirectory(PChar(PathName), 255);
//  Result.Add('实际位置：'#13#10 + PathName);
  FreeMem(PathName, 255);
end;

initialization
  PrHandle := PrintHandle;
  ExePath := ExtractFilePath(ParamStr(0));
  IniPath := ChangeFileExt(ParamStr(0), '.INI');
  Registed := HasRegister;
end.