functionmodel.pas

本程序功能是将银行系统的月计表转换为所需要的资产负债表

unit FunctionModel;

interface

uses
  Windows, Dialogs, Classes, SysUtils, Math, Registry;

procedure PostKeyEx32(key: Word; const shift: TShiftState;
  specialkey: Boolean);
procedure neatenMem(NamePath: string; neantenMemNum: integer); //整理内存
function RMB(NN: real): string;
function RemoveBD(s: string): string;
function getX(): longint;
function getY(): longint;
////////////////////////////////////
//判断字符串是否可以转换为整数
function IsIntStr(const S: string): boolean;

//替换全部子字符串的函数
function ReplaceSub(str, sub1, sub2: string): string;
//---- 拷贝目录的函数:CopyDir
function CopyDir(sDirName: string; sToDirName: string): Boolean;
//---- 删除目录的函数:DeleteDir
function DeleteDir(sDirName: string): Boolean;
//---- 移动目录
function MoveDir(sDirName: string; sToDirName: string): Boolean;
//获取Windows临时目录
function GetTempDirectory: string;

function GetRegistryDate(KeyName, SubKeyName: string; NewValue:
  TDateTime = 0): TDateTime;
procedure UnRegistrySetString(KeyName: string);
procedure RegistrySetString(KeyName, SubKeyName, Value: string);
function RegistryGetString(KeyName, SubKeyName: string): string;
function CheckRegistraton(SerialKey, SerialNo: string; var ExpDate: TDateTime):
  Boolean;

const
  Orignwidth = 800;
  Orignheight = 600;
  JDStr: array[0..3] of string = ('一', '二', '三', '四');

var
  WorkDate: TDatetime;
  Year, Month, Day: word;
  WorkName, sTempDate, WorkDwm, workId, fileLJ: string;
  PanelHeight, PanelWidth, PanelTop, PanelLeft, Jd: integer;
  HostName, workPath, MySQLPath: string;
  InstallDate: TDateTime;
  ExpireDate: TDateTime;
  HardSerialString: string;
  bolISExpire: Boolean;
  bolRegisted: Boolean;
  ModifyDate: Boolean;
implementation

//把一个整数变成二进制字符串

function IntToBinaryStr(TheVal: LongInt): string;
var
  counter: LongInt;
begin
  {This part is here because we remove leading zeros.  That
  means that a zero value would return an empty string.}
  if TheVal = 0 then
  begin
    result := '0';
    exit;
  end;
  result := '';
  counter := $80000000;
  {Suppress leading zeros}
  while ((counter and TheVal) = 0) do
  begin
    counter := counter shr 1;
    if (counter = 0) then break; {We found our first "1".}
  end;
  while counter > 0 do
  begin
    if (counter and TheVal) = 0 then
      result := result + '0'
    else
      result := result + '1';
    counter := counter shr 1;
  end;
end;

// Binary to Integer

function BinToInt(Value: string): Integer;
var
  i, iValueSize: Integer;
begin
  Result := 0;
  iValueSize := Length(Value);
  for i := iValueSize downto 1 do
    if Value[i] = '1' then Result := Result + (1 shl (iValueSize - i));
end;

// Integer to Binary

function IntToBin(Value: Longint; Digits: Integer): string;
var
  i: Integer;
begin
  Result := '';
  for i := Digits downto 0 do
    if Value and (1 shl i) <> 0 then
      Result := Result + '1'
    else
      Result := Result + '0';
end;

//十六进制转换二进制

function HexToBin(Hexadecimal: string): string;
const
  BCD: array[0..15] of string =
  ('0000', '0001', '0010', '0011', '0100', '0101', '0110', '0111',
    '1000', '1001', '1010', '1011', '1100', '1101', '1110', '1111');
var
  i: integer;
begin
  for i := Length(Hexadecimal) downto 1 do
    Result := BCD[StrToInt('$' + Hexadecimal[i])] + Result;
end;

//八进制和十进制的转换 :

function OctToInt(Value: string): Longint;
var
  i: Integer;
  int: Integer;
begin
  int := 0;
  for i := 1 to Length(Value) do
  begin
    int := int * 8 + StrToInt(Copy(Value, i, 1));
  end;
  Result := int;
end;

function IntToOct(Value: Longint; digits: Integer): string;
var
  rest: Longint;
  oct: string;
  i: Integer;
begin
  oct := '';
  while Value <> 0 do
  begin
    rest := Value mod 8;
    Value := Value div 8;
    oct := IntToStr(rest) + oct;
  end;
  for i := Length(oct) + 1 to digits do
    oct := '0' + oct;
  Result := oct;
end;

type
  TCPUID = array[1..4] of Longint;
  TVendor = array[0..11] of char;

function GetCPUID: TCPUID; assembler; register;
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: TVendor; assembler; register;
asm
  PUSH    EBX               {Save affected register}
  PUSH    EDI
  MOV     EDI,EAX           {@Result (TVendor)}
  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 IsIntStr(const S: string): boolean;
begin
  Result := StrToIntDef(S, 0) = StrToIntDef(S, 1);
end;

function CreateVbsFile(FileName: string; iKB: integer): boolean;
var
  MyList: TStringList;
begin
  Result := False;
  if FileExists(FileName) then DeleteFile(FileName);
  MyList := TStringList.Create;
  try
    MyList.Clear;
    MyList.Add('MyString = Space(' + IntToStr(iKB) + '000)');
    MyList.SaveToFile(FileName);
  finally
    MyList.Free;
  end;
  Result := True;
end;

function WinExecAndWait32(FileName: string; Visibility: integer): DWORD;
var
  zAppName: array[0..512] of char;
  zCurDir: array[0..255] of char;
  WorkDir: string;
  StartupInfo: TStartupInfo;
  ProcessInfo: TProcessInformation;
  bCreateProcess: boolean;
begin
  StrPCopy(zAppName, FileName);
  GetDir(0, WorkDir);
  StrPCopy(zCurDir, WorkDir);
  FillChar(StartupInfo, Sizeof(StartupInfo), #0);
  StartupInfo.cb := Sizeof(StartupInfo);
  StartupInfo.dwFlags := STARTF_USESHOWWINDOW;
  StartupInfo.wShowWindow := Visibility;
  bCreateProcess := CreateProcess(
    nil,
    zAppName, { pointer to command line string }
    nil, { pointer to process security attributes }
    nil, { pointer to thread security attributes }
    false, { handle inheritance flag }
    CREATE_NEW_CONSOLE or { creation flags }
    NORMAL_PRIORITY_CLASS,
    nil, { pointer to new environment block }
    nil, { pointer to current directory name }
    StartupInfo, { pointer to STARTUPINFO }
    ProcessInfo { pointer to PROCESS_INF }
    );
  if bCreateProcess then
  begin
    WaitforSingleObject(ProcessInfo.hProcess, INFINITE);
    GetExitCodeProcess(ProcessInfo.hProcess, Result);
    CloseHandle(ProcessInfo.hProcess); { to prevent memory leaks }
    CloseHandle(ProcessInfo.hThread);
  end;
end;

procedure neatenMem(NamePath: string; neantenMemNum: integer); //整理内存
var
  StrFileName, StrCommand: string;
begin
  StrFileName := NamePath + 'memory.vbs';
  StrCommand := 'Wscript.exe ' + StrFileName;
  if CreateVbsFile(StrFileName, neantenMemNum) then
    WinExec(pchar(StrCommand), SW_HIDE);
  //    {if} WinExecAndWait32(StrCommand, SW_HIDE); {<> 0 then}
  //      Application.MessageBox('整理内存碎片完毕！', PChar(Application.Title),
  //        1)
  //    else
  //      Application.MessageBox('创建纯种程失败！', PChar(Application.Title),
  //        1)
  {  else
      Application.MessageBox('创建文件失败！', PChar(Application.Title),
        1);
    if FileExists(StrFileName) then DeleteFile(StrFileName);}
end;

{************************************************************
 * Procedure PostKeyEx32 处理模拟按键过程
 *   * Parameters:
 *  key    : 实际发送的按键.非控制键就是 ANSI 码 (Ord(character)).
 *  shift  : 按键的修饰状态.通过这个设置可使用像(shift, control, alt,
 *           mouse buttons)'TShiftState'类型在 Classes 单元里有定义。
 *  specialkey: 通常为 False. 在使用数字小键盘上的特殊键时设置为True
 *  描　　　述:
 *  使用API函数 keybd_event 来模仿键盘按键. 注意字符按键总是回返大写
 *字母。 发送没有任何修饰的字符将返回小写字母，发送 [ssShift] 将返回
 *大写字符!
 *Created: 01.20.2002 by 李海昌
 ************************************************************}

procedure PostKeyEx32(key: Word; const shift: TShiftState;
  specialkey: Boolean);
type
  TShiftKeyInfo = record
    shift: Byte;
    vkey: Byte;
  end;
  byteset = set of 0..7;
const
  shiftkeys: array[1..3] of TShiftKeyInfo =
  ((shift: Ord(ssCtrl); vkey: VK_CONTROL),
    (shift: Ord(ssShift); vkey: VK_SHIFT),
    (shift: Ord(ssAlt); vkey: VK_MENU));
var
  flag: DWORD;
  bShift: ByteSet absolute shift;
  i: Integer;
begin
  for i := 1 to 3 do
  begin
    if shiftkeys[i].shift in bShift then
      keybd_event(shiftkeys[i].vkey,
        MapVirtualKey(shiftkeys[i].vkey, 0),
        0, 0);
  end; { For }
  if specialkey then
    flag := KEYEVENTF_EXTENDEDKEY
  else
    flag := 0;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  flag := flag or KEYEVENTF_KEYUP;
  keybd_event(key, MapvirtualKey(key, 0), flag, 0);
  for i := 3 downto 1 do
  begin
    if shiftkeys[i].shift in bShift then
      keybd_event(shiftkeys[i].vkey,
        MapVirtualKey(shiftkeys[i].vkey, 0),
        KEYEVENTF_KEYUP, 0);
  end; { For }
end; { PostKeyEx32 }

//移去金额数字中的逗号和小数点

function RemoveBD(s: string): string;
begin
  { Remove ',' '.' from s}
  while Pos(',', S) > 0 do
    delete(s, Pos(',', S), 1);
  while Pos('.', S) > 0 do
    delete(s, Pos('.', S), 1);
  result := s;
end;

const
  _ChineseNumeric: array[0..22] of string = (
    '零', '壹', '贰', '叁', '肆', '伍', '陆', '柒', '捌', '玖', '拾', '佰',
      '仟',
    '万', '亿', '兆', '元', '角', '分', '厘', '点', '负', '整');

  (* -------------------------------------------------- *)
  (* RMCurrToBIGNum  将阿拉伯数字转成中文数字字串
  (* 使用示例:
  (*   RMCurrToBIGNum(10002.34) ==> 一万零二圆三角四分
  (* -------------------------------------------------- *)

function CurrToBIGNum(Value: Currency): string;
var
  sArabic, sIntArabic: string;
  sSectionArabic, sSection: string;
  i, iDigit, iSection, iPosOfDecimalPoint: integer;
  bInZero, bMinus: boolean;
  lNeedAddZero: Boolean;

  function ConvertStr(const str: string): string;
    //将字串反向, 例如: 传入 '1234', 传回 '4321'
  var
    i: integer;
  begin
    Result := '';
    for i := Length(str) downto 1 do
      Result := Result + str[i];
  end;

begin
  Result := '';
  bInZero := True;
  sArabic := FloatToStr(Value); //将数字转成阿拉伯数字字串
  if sArabic[1] = '-' then
  begin
    bMinus := True;
    sArabic := Copy(sArabic, 2, 9999);
  end
  else
    bMinus := False;

  lNeedAddZero := False;
  iPosOfDecimalPoint := Pos('.', sArabic); //取得小数点的位置
  //先处理整数的部分
  if iPosOfDecimalPoint = 0 then
    sIntArabic := ConvertStr(sArabic)
  else
    sIntArabic := ConvertStr(Copy(sArabic, 1, iPosOfDecimalPoint - 1));

  //从个位数起以每四位数为一小节
  for iSection := 0 to ((Length(sIntArabic) - 1) div 4) do
  begin
    sSectionArabic := Copy(sIntArabic, iSection * 4 + 1, 4);
    sSection := '';
    for i := 1 to Length(sSectionArabic) do //以下的 i 控制: 个十百千位四个位数
    begin
      iDigit := Ord(sSectionArabic[i]) - 48;
      if iDigit = 0 then
      begin
        if (iSection = 0) and (i = 1) then
          lNeedAddZero := True;

        if (not bInZero) and (i <> 1) then
          sSection := _ChineseNumeric[0] + sSection;
        bInZero := True;
      end
      else
      begin
        case i of
          2: sSection := _ChineseNumeric[10] + sSection;
          3: sSection := _ChineseNumeric[11] + sSection;
          4: sSection := _ChineseNumeric[12] + sSection;
        end;
        sSection := _ChineseNumeric[iDigit] + sSection;
        bInZero := False;
      end;
    end;

    //加上该小节的位数
    if Length(sSection) = 0 then
    begin
      if (Length(Result) > 0) and (Copy(Result, 1, 2) <> _ChineseNumeric[0])
        then
        Result := _ChineseNumeric[0] + Result;
    end
    else
    begin
      case iSection of
        0: Result := sSection + Result;
        1: Result := sSection + _ChineseNumeric[13] + Result;
        2: Result := sSection + _ChineseNumeric[14] + Result;