unit XEDUSER;

interface

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

const
  SysFile = 'D:\PAS\XED.INT';
  DeleRec = '該操作將會刪除當前的記錄，'#13#13'確實要刪除當前這條記錄嗎？';
  TellAuthor = '程序作者：謝深剛 Tel: 0757-224639X';
type
  TCPUID = array[1..4] of Longint;
  TVChar = array[0..11] of char;

var
  KeyPath: string = 'SoftWare\MicroSoft\Windows\CurrentVersion\';
  MainCap: string = '';

  ShopCode: string = '';
  ShopName: string = '';
  CompName: string = '';
  ShopPass: string = '';
  ExePath: string = '';
  IniPath: string = '';
  CanEdit: Boolean = True;
  FirstUse: Boolean = True;
  OpenFile: Boolean = False;
  Registed: Boolean = False;
  MakeNews: Boolean = False;
  PassKey: string = 'FGPresent';
  SuppUser: boolean = false;
  SettUser: boolean = false;
const
  RowMovementKeys = [VK_UP, VK_PRIOR, VK_DOWN, VK_NEXT, VK_HOME, VK_END];

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;
function DupStr(C: Char; N: integer): string;
function Answer(S: string): Boolean;
function TellMe(S: string): Boolean; overload;
function TellMe(N: integer): Boolean; overload;
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 SetLocPrint(PS: TStringList): Boolean; overload;
function GetLocPrint(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): DWORD;
function OutofDate: Boolean;
function EncodeStr(S: string): string;
function EncodeME(R: Integer): string;
function DecodeME(S: string): Integer;
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;
function GetQuick(Input: string): string;
procedure LoadImage(TB: TDataSet; Field: string; Img: TImage);
procedure SaveImage(TB: TDataSet; Field: string; Img: TImage);

function Desktop: string;
function IPAddress: string;
procedure MakeShort(PathName, WorkDir: PChar; LinkPath: WideString);
procedure DeskShort(PathName: string; LinkName: WideString);
function NetCardAddr: string;
procedure ChineseDate(M: integer);
procedure OpenIniFile(var F: TIniFile);

procedure CopyFile12(F1, F2: string);

implementation

procedure ChineseDate(M: integer);
begin
  if M = 0 then ShortDateFormat := 'yy/mm/dd';
  if M = 1 then ShortDateFormat := 'YYYY"年"MM"月"DD"日"';
end;

procedure OpenIniFile(var F: TIniFile);
begin
  F := TIniFile.Create(IniPath);
end;

function DupStr(C: Char; N: integer): string;
begin
  result := StringOfChar(C, N);
end;

procedure CopyFile12(F1, F2: string);
var
  FF: TMemoryStream;
begin
  FF := TMemoryStream.Create;
  FF.LoadFromFile(F1);
  FF.SaveToFile(F2);
  FF.Free;
end;

function Answer(S: string): Boolean;
var
  ID: Integer;
begin
  ID := Application.MessageBox(PChar(S), '系統提示',
    MB_YESNOCANCEL + MB_ICONQUESTION);
  Result := ID = ID_YES;
{  if ID = ID_CANCEL then begin
    Result := False;
  end;}
end;

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 NetCardAddr: string;
var
  AdapterStatus: PAdapterStatus;
  StatNCB: PNCB;
  I: Integer;
  MACAddress: array[1..6] of Byte;
begin
  New(StatNCB);
  ZeroMemory(StatNCB, SizeOf(TNCB));
  StatNCB.ncb_length := SizeOf(TAdapterStatus) + $FF * SizeOf(TNameBuffer);
  GetMem(AdapterStatus, StatNCB.ncb_length);
  StatNCB.ncb_buffer := PChar(AdapterStatus);
  StatNCB.ncb_callname := '*' + #0;
  StatNCB.ncb_lana_num := #0;
  StatNCB.ncb_command := Char(NCBASTAT);
  NetBios(StatNCB);
  if Byte(StatNCB.ncb_cmd_cplt) = NRC_GOODRET then
  begin
    MoveMemory(@MACAddress, AdapterStatus, SizeOf(MACAddress));
    for i := 1 to 6 do
      Result := Result + Format('%2.2x', [MACAddress[i]]);
  end else Result := '';
  FreeMem(AdapterStatus);
  Dispose(StatNCB);
end;

function IPAddress: string;
var
  WSData: TWSAData;
  MyHost: PHostEnt;
  CH: array[0..127] of Char;
  I: Word;
  T: PChar;
  S: string;
begin
  WSAstartup(2, WSData);
  GetHostName(@Ch[1], 32);
  MyHost := GetHostByName(@Ch[1]);
//  PP := PInAddr(MyHost.H_Addr^);
//  Result := iNet_ntoa(PP^);
  T := PChar(MyHost.H_Addr^);
  S := '';
  for I := 0 to 3 do begin
    S := S + Format('%d', [Ord(T[I])]);
    if I < 3 then S := S + '.';
  end;
  Result := S;
end;

{function IPAddress: string;
var
  WSData: TWSAData;
  MyHost: PHostEnt;
  CH: array[0..127] of Char;
  I: Word;
  T: PChar;
  S: string;
begin
  WSAstartup(2, WSData);
  GetHostName(@Ch[1], 32);
  MyHost := GetHostByName(@Ch[1]);
//  PP := PInAddr(MyHost.H_Addr^);
//  Result := iNet_ntoa(PP^);
  T := PChar(MyHost.H_Addr^);
  S := '';
  for I := 0 to 3 do begin
    S := S + FormatFloat('000', Ord(T[I]));
    if I < 3 then S := S + '.';
  end;
  Result := S;
end;
}

function Desktop: string;
var
  P_IDL: PItemIDList;
  Desk: array[0..MAX_PATH] of Char;
begin
  SHGetSpecialFolderLocation(0, CSIDL_DESKTOPDIRECTORY, P_IDL);
  SHGetPathFromIDList(P_IDL, Desk);
  Result := Desk;
end;

procedure MakeShort(PathName, WorkDir: PChar; LinkPath: WideString);
var
  MYObject: IUnknown;
  SLink: IShellLink;
  PFile: IPersistFile;
begin
  MYObject := CreateComObject(CLSID_ShellLink) as IShellLink;
  SLink := MYObject as IShellLink;
  PFile := MYObject as IPersistFile;

  SLink.SetPath(PathName);
  SLink.SetWorkingDirectory(WorkDir);

  SLink.QueryInterface(IPersistFile, PFile);
  PFile.Save(pWChar(LinkPath), True);
end;

procedure LoadImage(TB: TDataSet; Field: string; Img: TImage);
var
  MS: TBlobStream;
  JP: TJPEGImage;
  AA: array[1..10] of Char;
begin
  Img.Picture := nil;
  MS := TBlobStream.Create(TBlobField(TB.FieldByName(Field)), bmRead);
  MS.Read(AA[1], 10);
  if (AA[1] + AA[2] = 'BM') or (AA[9] + AA[10] = 'BM') then begin
    if AA[1] = 'B' then begin MS.Seek(0, 0); end else
      if AA[9] = 'B' then begin MS.Seek(8, 0); end;
    Img.Picture.Bitmap.LoadFromStream(MS);
  end else begin
    MS.Seek(0, 0);
    JP := TJPEGImage.Create;
    JP.LoadFromStream(MS);
    Img.Canvas.StretchDraw(Img.ClientRect, JP);
    JP.Free;
  end;
  MS.Free;
end;

procedure SaveImage(TB: TDataSet; Field: string; Img: TImage);
var
  MS: TBlobStream;
begin
  if not (TB.State in [dsEdit, dsInsert]) then TB.Edit;
  MS := TBlobStream.Create(TBlobField(TB.FieldByName(Field)), bmWrite);
  if Img.Picture.Graphic is TJPEGImage then
    TJPEGImage(Img.Picture.Graphic).SaveToStream(MS)
  else
    Img.Picture.Bitmap.SaveToStream(MS);
  MS.Free;
  TB.Post;
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')) + ', ';
  Delete(Result, Length(Result) - 1, 2);
  Result := Result + ']';
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;
      TellME('設置指定的網絡驅動器作為系統數據庫路徑');