xeduser.pas

特别方便的工具程序

unit XEDUSER;

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

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

var
  KeyPath: string = 'SoftWare\MicroSoft\Windows\CurrentVersion\';
  MainCap: string = '';
  ShopName: string = '';
  CompName: string = '';
  ShopPass: string = '';
  ShopExec: string = '';
  ExePath: string = '';
  IniPath: string = '';
  CanEdit: Boolean = True;
  FirstUse: Boolean = True;
  OpenFile: Boolean = False;
  Registed: Boolean = False;
  MakeNews: Boolean = False;
  PassKey: string = 'Present';

var
  RegPass, CurPass: string;
  Name1, Name2: string;
  DeskBMP: string;
  CoName, SetTel: string;
  Truant: Word;
var
  Grade: Integer;
  SX, SY: Word;
  GDate1, GDate2: TDate;
  PrHandle: THandle;
procedure Run(S: string);
function NewCom(var Comb: TComboBox): Boolean;
procedure UpdateFieldName(Table: TTable; Mode: Boolean);
procedure SetRatio(X, Y: Word);
function GetDrive: string;
procedure SetAlias(NameStr, Dirstr: string);
procedure SetDBPass(Table: TTable; PS: string);
procedure PackTable(Table: TTable); overload;
procedure PackTable(Name: string); overload;
procedure PickStr(P: TColumn; tb: TTable; S: string);
procedure CloseMDI(H: THandle);

procedure GetPaper(List: TStrings);

function SetLocPrint(spSize, Wide, Leng: Integer; spOrder: Boolean): Boolean; overload;
function GetLocPrint(var spSize, Wide, Leng: Integer; var spOrder: Boolean): Boolean; overload;
function GetLocPrint(PS: TStringList): Boolean; overload;
function SetLocPrint(PS: TStringList): Boolean; overload;

function SetSysPrint(spSize, Wide, Leng: Integer; spOrder: Boolean): Boolean;
function GetSysPrint(var spSize, Wide, Leng: Integer; var spOrder: Boolean): Boolean;
function PrintName: PChar;
function PrintHandle: Cardinal;
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(Form: TForm; Key: string);
procedure SaveSite(Form: TForm; Key: string);
function GetPYStr(HZStr: WideString): string;
procedure RedrawForm(Sender: TObject);
function CoinStr(SumCoin: Real): string;
function OICQ(const FName: string = 'C:\Program Files\Tencent\Dat\OICQ2000.CFG'): string;
procedure DeskShort(PathName: string; LinkName: WideString);
function TellMe(S: string): Boolean; overload;
function TellMe(N: integer): Boolean; overload;
function GetQuick(Input: string): string;

implementation

function TellMe(S: string): Boolean;
var
  ID: Integer;
begin
  ID := Application.MessageBox(PChar(S), '系统提示',
    MB_OK + MB_ICONQUESTION);
  Result := ID = ID_YES;
end;

function TellMe(N: integer): Boolean;
var
  ID: Integer;
begin
  ID := Application.MessageBox(PChar(IntToStr(N)), '系统提示',
    MB_OK + MB_ICONQUESTION + MB_TOPMOST);
  Result := ID = ID_YES;
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;

procedure UpdateFieldName(Table: TTable; Mode: Boolean);
var
  Props: CURProps;
  hDb: hDBIDb;
  TableDesc: CRTblDesc;
  pFields: pFLDDesc;
  pOp: pCROpType;
  N: Byte;
begin
  Table.Close;
  Table.Exclusive := True;
  Table.Open;
  Check(DbiSetProp(hDBIObj(Table.Handle), curxltMODE, Integer(xltNONE)));
  Check(DbiGetCursorProps(Table.Handle, Props));
  if (Props.szTableType <> szPARADOX) and (Props.szTableType <> szDBASE) then
    raise EDatabaseError.Create('只是针对: Paradox, dBASE');

  pFields := AllocMem(Table.FieldCount * sizeof(FLDDesc));
  pOp := AllocMem(Table.FieldCount * sizeof(CROpType));
  try
    pOp^ := crMODIFY;
    Check(DbiGetFieldDescs(Table.Handle, pFields));
    for N := 1 to Table.FieldCount do begin
      pFields.iFldNum := N;
//      if Mode then StrPCopy(pFields.szName, GBToBIG5(pFields.szName))
//      else
//      StrPCopy(pFields.szName, BIG5ToGB(pFields.szName));
      Inc(pFields, 1);
    end;
    Dec(pFields, Table.FieldCount);
    FillChar(TableDesc, sizeof(TableDesc), #0);
    Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));

    StrPCopy(TableDesc.szTblName, Table.TableName);
    StrPCopy(TableDesc.szTblType, Props.szTableType);
    TableDesc.iFldCount := Table.FieldCount;
    TableDesc.pecrFldOp := pOp;
    TableDesc.pFldDesc := pFields;
    Table.Close;
    Check(DbiDoRestructure(hDb, 1, @TableDesc, nil, nil, nil, False));
  finally
    if pOp <> nil then FreeMem(pOp);
    if pFields <> nil then FreeMem(pFields);
  end;
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 SetDBPass(Table: TTable; PS: string);
var
  TblDesc: CRTblDesc;
  hDb: hDBIDb;
  O, M: Boolean;
begin
  O := Table.Active;
  M := Table.Exclusive;
  Table.Open;
  HDb := Table.Database.Handle;
//  Check(DbiGetObjFromObj(hDBIObj(Table.Handle), objDATABASE, hDBIObj(hDb)));
  Table.Close;
  Table.Exclusive := True;
  FillChar(TblDesc, SizeOf(CRTblDesc), 0);
  StrPCopy(TblDesc.szTblName, Table.TableName);
  StrCopy(TblDesc.szTblType, szPARADOX);
  StrPCopy(TblDesc.szPassword, Ps);
  TblDesc.bProtected := True;

  { 添加主口令到PARADOX表里}
  Check(DbiDoRestructure(hDb, 1, @TblDesc, nil, nil, nil, FALSE));
   {添加一个新口令到SESSION}
  Table.Exclusive := M;
  Table.Active := O;
end;

procedure PackTable(Table: TTable);
var
  Props: CURProps;
  hDb: hDBIDb;
  TableDesc: CRTblDesc;
begin
  Table.Close;
  Table.Exclusive := True;
  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
    on E: Exception do begin
      Beep;
      ShowMessage(E.Message);
    end;
  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 GetPaper(List: TStrings);
type
  TPaperName = array[1..64] of Char;
  TPaperNames = array[0..0] of TPaperName;
  PPaperNames = ^TPaperNames;

  TPaper = Word;
  TPapers = array[0..0] of TPaper;
  PPapers = ^TPapers;
var
  Dev, Drv, Port: array[1..128] of Char;
  hDMode: THandle;
  pDMode: PDevMode;
  I, Num: Integer;
  PAPERNAMES: PPaperNames;
  PAPERS: PPapers;
begin
  Printer.GetPrinter(@Dev, @Drv, @Port, hDMode);
  if hDMode <> 0 then begin
    pDMode := GlobalLock(hDMode);
    //获取纸张名称
    Num := DeviceCapabilities(@Dev, @Port, DC_PAPERNAMES, nil, @pDMode);
    GetMem(PAPERNAMES, Num * Sizeof(TPaperName));
    DeviceCapabilities(@Dev, @Port, DC_PAPERNAMES, PChar(PAPERNAMES), @pDMode);

    //获取纸张大小
    Num := DeviceCapabilities(@Dev, @Port, DC_PAPERS, nil, @pDMode);
    GetMem(PAPERS, Num * Sizeof(TPaper));
    DeviceCapabilities(@Dev, @Port, DC_PAPERS, PChar(PAPERS), @pDMode);
    for i := 0 to Num - 1 do List.AddObject(PaperNames[i], TObject(Papers[i]));
    GlobalUnlock(hDMode);
  end;
end;

function GetLocPrint(var spSize, Wide, Leng: Integer; var 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.GetPrinter(@Dev, @Drv, @Port, hDMode);
  if hDMode <> 0 then begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then begin
      spOrder := pDMode.dmOrientation = 1;
      spSize := pDMode.dmPaperSize;
      Wide := pDMode.dmPaperWidth;
      Leng := pDMode.dmPaperLength;
    end;
    GlobalUnlock(hDMode);
  end;
  Result := True;
end;

function SetLocPrint(spSize, Wide, Leng: Integer; spOrder: Boolean): Boolean; overload;
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 := spSize;
      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 GetLocPrint(PS: TStringList): 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
  PS.Clear;
  Printer.GetPrinter(@Dev, @Drv, @Port, hDMode);
  if hDMode <> 0 then begin
    pDMode := GlobalLock(hDMode);
    if pDMode <> nil then begin
      PS.Add(Format('纸张=%d', [pDMode.dmPaperSize]));
      PS.Add(Format('宽度=%d', [pDMode.dmPaperWidth]));
      PS.Add(Format('长度=%d', [pDMode.dmPaperLength]));
      PS.Add(Format('方向=%d', [pDMode.dmOrientation]));
    end;
    GlobalUnlock(hDMode);
  end;
  Result := True;
end;

function SetLocPrint(PS: TStringList): 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
      pDMode.dmPaperSize := StrToInt(PS.Values['纸张']);
      pDMode.dmPaperWidth := StrToInt(PS.Values['宽度']);
      pDMode.dmPaperLength := StrToInt(PS.Values['长度']);
      pDMode.dmOrientation := StrToInt(PS.Values['方向']);
      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 GetSysPrint(var spSize, Wide, Leng: Integer; var spOrder: Boolean): Boolean;
var
  S3: Cardinal;
  P1: _PRINTER_INFO_2;
  DV: Devmode;
  Buffer: array[1..1200] of Byte;
begin
  S3 := 1000;
  spSize := 0;
  spOrder := True;
  if not GetPrinter(PrHandle, 2, @Buffer[1], S3, @S3) then
  begin
    Result := False;
    Exit;
  end;
  Move(Buffer[1], P1, Sizeof(P1));