functionmodel.pas

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

        3: Result := sSection + _ChineseNumeric[15] + Result;
      end;
    end;
  end;

  if Length(Result) > 0 then
    Result := Result + _ChineseNumeric[16];
  if iPosOfDecimalPoint > 0 then //处理小数部分
  begin
    if lNeedAddZero then // 需要加"零", 107000.53:壹拾万柒仟元零伍角叁分
      Result := Result + _ChineseNumeric[0];

    for i := iPosOfDecimalPoint + 1 to Length(sArabic) do
    begin
      iDigit := Ord(sArabic[i]) - 48;
      if not ((iDigit = 0) and lNeedAddZero) then
        Result := Result + _ChineseNumeric[iDigit];

      case i - (iPosOfDecimalPoint + 1) of
        0:
          begin
            if iDigit > 0 then
              Result := Result + _ChineseNumeric[17];
          end;
        1: Result := Result + _ChineseNumeric[18];
        2: Result := Result + _ChineseNumeric[19];
      end;
    end;
  end;

  //其他例外状况的处理
  if Length(Result) = 0 then
    Result := _ChineseNumeric[0] + _ChineseNumeric[16];
  //  if Copy(Result, 1, 4) = _ChineseNumeric[1] + _ChineseNumeric[10] then
  //    Result := Copy(Result, 3, 254);
  if Copy(Result, 1, 2) = _ChineseNumeric[20] then
    Result := _ChineseNumeric[0] + Result;

  if bMinus then
    Result := _ChineseNumeric[21] + Result;
  if ((Round(Value * 100)) div 1) mod 10 = 0 then
    Result := Result + _ChineseNumeric[22];
end;

function RMB(NN: real): string;
var
  HZ, NS, NW, NA, N1, N2: string;
  LA, X, Nk: integer;
begin
  if NN > 9999999999999.99 then
  begin
    MessageDlg('金额溢出.', mtError, [mbOk], 0);
    HZ := '';
    Result := HZ;
    exit;
  end;
  if NN = 0 then
  begin
    HZ := '零元';
    result := HZ;
    exit;
  end;
  NS := '零壹贰叁肆伍陆柒捌玖';
  NW := '分角元拾佰仟万拾佰仟亿拾佰仟万';
  NA := FloatToStr(NN * 100);
  LA := length(NA);
  X := 1;
  HZ := '';
  while X <= LA do
  begin
    NK := Ord(NA[x]) - Ord('0');
    N1 := Copy(NS, NK * 2 + 1, 2);
    N2 := Copy(NW, LA * 2 + 1 - X * 2, 2);
    if (NK = 0) and ((N2 = '亿') or (N2 = '万') or (N2 = '元')) then
    begin
      if copy(HZ, Length(HZ) - 1, 2) = '零' then
        HZ := copy(HZ, 1, length(HZ) - 2);
      if copy(HZ, Length(HZ) - 1, 2) = '亿' then
        if N2 = '元' then
        begin
          N1 := N2;
          N2 := '零';
        end
        else
          N2 := ''
      else
      begin
        N1 := N2;
        N2 := '零';
      end
    end
    else
      if NK = 0 then
      begin
        if copy(HZ, length(HZ) - 1, 2) = '零' then
          N1 := '';
        if N2 = '分' then
        begin
          if copy(HZ, length(HZ) - 1, 2) = '零' then
            HZ := copy(HZ, 1, length(HZ) - 2) + '整'
          else
            HZ := HZ + '整';
          N1 := '';
        end;
        N2 := '';
      end;
    HZ := HZ + N1 + N2;
    X := X + 1
  end;
  Result := HZ;
end;

function getX(): longint;
begin
  result := GetSystemMetrics(SM_CXSCREEN);
end;

function getY(): longint;
begin
  result := GetSystemMetrics(SM_CYSCREEN);
end;
////////////////////////
//替换全部子字符串的函数

function ReplaceSub(str, sub1, sub2: string): string;
var
  aPos: Integer;
  rslt: string;

begin
  aPos := Pos(sub1, str);
  rslt := '';
  while (aPos <> 0) do
  begin
    rslt := rslt + Copy(str, 1, aPos - 1) + sub2;
    Delete(str, 1, aPos + Length(sub1) - 1);
    aPos := Pos(sub1, str);
  end;
  Result := rslt + str;
end;

//---- 1.1拷贝目录的递归辅助函数:DoCopyDir

function DoCopyDir(sDirName: string; sToDirName: string): Boolean;
var
  hFindFile: Cardinal;
  t, tfile: string;
  sCurDir: string[255];
  FindFileData: WIN32_FIND_DATA;
begin
  //先保存当前目录
  sCurDir := GetCurrentDir;
  ChDir(sDirName);
  hFindFile := FindFirstFile('*.*', FindFileData);
  if hFindFile <> INVALID_HANDLE_VALUE then
  begin
    if not DirectoryExists(sToDirName) then
      ForceDirectories(sToDirName);
    repeat
      tfile := FindFileData.cFileName;
      if (tfile = '.') or (tfile = '..') then
        Continue;
      if FindFileData.dwFileAttributes =
        FILE_ATTRIBUTE_DIRECTORY then
      begin
        t := sToDirName + '\' + tfile;
        if not DirectoryExists(t) then
          ForceDirectories(t);
        if sDirName[Length(sDirName)] <> '\' then
          DoCopyDir(sDirName + '\' + tfile, t)
        else
          DoCopyDir(sDirName + tfile, t);
      end
      else
      begin
        t := sToDirName + '\' + tFile;
        CopyFile(PChar(tfile), PChar(t), True);
      end;
    until FindNextFile(hFindFile, FindFileData) = false;
    Windows.FindClose(hFindFile);
  end
  else
  begin
    ChDir(sCurDir);
    result := false;
    exit;
  end;
  //回到原来的目录下
  ChDir(sCurDir);
  result := true;
end;

//---- 1.2拷贝目录的函数:CopyDir

function CopyDir(sDirName: string; sToDirName: string): Boolean;
begin
  if Length(sDirName) <= 0 then
    exit;
  //拷贝...
  Result := DoCopyDir(sDirName, sToDirName);
end;

//---- 2、删除目录
//
//---- 删除目录与拷贝目录很类似,但为了能删除位于根目录下的一个空目录,需要在辅助函数中设置一个标志变量,即:如果删除的是空目录,则置bEmptyDir为True,这一句已经用深色框表示了。
//
//---- 2.1删除目录的递归辅助函数:DoRemoveDir

function DoRemoveDir(sDirName: string): Boolean;
var
  hFindFile: Cardinal;
  tfile: string;
  sCurDir: string;
  bEmptyDir: Boolean;
  FindFileData: WIN32_FIND_DATA;
begin
  //如果删除的是空目录,则置bEmptyDir为True
  //初始时,bEmptyDir为True
  bEmptyDir := True;
  //先保存当前目录
  sCurDir := GetCurrentDir;
  SetLength(sCurDir, Length(sCurDir));
  ChDir(sDirName);
  hFindFile := FindFirstFile('*.*', FindFileData);
  if hFindFile <> INVALID_HANDLE_VALUE then
  begin
    repeat
      tfile := FindFileData.cFileName;
      if (tfile = '.') or (tfile = '..') then
      begin
        bEmptyDir := bEmptyDir and True;
        Continue;
      end;
      //不是空目录,置bEmptyDir为False
      bEmptyDir := False;
      if FindFileData.dwFileAttributes =
        FILE_ATTRIBUTE_DIRECTORY then
      begin
        if sDirName[Length(sDirName)] <> '\' then
          DoRemoveDir(sDirName + '\' + tfile)
        else
          DoRemoveDir(sDirName + tfile);
        if not RemoveDirectory(PChar(tfile)) then
          result := false
        else
          result := true;
      end
      else
      begin
        if not DeleteFile(PChar(tfile)) then
          result := false
        else
          result := true;
      end;
    until FindNextFile(hFindFile, FindFileData) = false;
    Windows.FindClose(hFindFile);
  end
  else
  begin
    ChDir(sCurDir);
    result := false;
    exit;
  end;
  //如果是空目录,则删除该空目录
  if bEmptyDir then
  begin
    //返回上一级目录
    ChDir('..');
    //删除空目录
    RemoveDirectory(PChar(sDirName));
  end;

  //回到原来的目录下
  ChDir(sCurDir);
  result := true;
end;

//---- 2.2删除目录的函数:DeleteDir

function DeleteDir(sDirName: string): Boolean;
begin
  if Length(sDirName) <= 0 then
    exit;
  //删除...
  Result := DoRemoveDir(sDirName) and RemoveDir(sDirName);
end;

//- - - -3 、移动目录
//
//- - - -有了拷贝目录和删除目录的函数, 移动目录就变得很简单, 只需顺序调用前两个函数即可:

function MoveDir(sDirName: string; sToDirName: string): Boolean;
begin
  if CopyDir(sDirName, sToDirName) then
    if RemoveDir(sDirName) then
      result := True
    else
      result := false;
end;

//获取Windows临时目录

function GetTempDirectory: string;
var
  TempDir: array[0..255] of Char;
begin
  GetTempPath(255, @TempDir);
  Result := StrPas(TempDir);
end;

//对注册表中的日期进行读写，如果指定了新的日期，则把新的日期写入注册表
//使用二进制代码，以免被用户修改

function GetRegistryDate(KeyName, SubKeyName: string; NewValue:
  TDateTime): TDateTime;
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create(KEY_ALL_ACCESS);
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;

    if Registry.OpenKey(KeyName, False) then
    try
      Result := Registry.ReadDate(SubKeyName);
    except
      Result := 0;
    end
    else
    begin
      Registry.OpenKey(KeyName, True);
      Result := Now;
      Registry.WriteDate(SubKeyName, Result);
    end;
    if NewValue > Result then
      Registry.WriteDate(SubKeyName, NewValue);
  finally
    Registry.Free;
  end;
end;

//从注册表里删字符串信息

procedure UnRegistrySetString(KeyName: string);
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create(KEY_ALL_ACCESS);
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;

    Registry.DeleteKey(KeyName);
  finally
    Registry.Free;
  end;
end;

//往注册表里写字符串信息

procedure RegistrySetString(KeyName, SubKeyName, Value: string);
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create(KEY_ALL_ACCESS);
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;

    Registry.OpenKey(KeyName, True);
    Registry.WriteString(SubKeyName, Value);
  finally
    Registry.Free;
  end;
end;

//从注册表里获取字符串信息，如果键名不存在，则返回空字符串。

function RegistryGetString(KeyName, SubKeyName: string): string;
var
  Registry: TRegistry;
begin
  Registry := TRegistry.Create(KEY_ALL_ACCESS);
  try
    Registry.RootKey := HKEY_LOCAL_MACHINE;

    if Registry.OpenKey(KeyName, False) then
    try
      Result := Registry.ReadString(SubKeyName);
    except
      Result := '';
    end
    else
      Result := '';
  finally
    Registry.Free;
  end;
end;

function CheckRegistraton(SerialKey, SerialNo: string; var ExpDate: TDateTime):
  Boolean;
var
  HardSerial: string;
  HardSerialChar: Char;
  ChrIndex: Integer;
  CheckSum: Integer;
  CheckDiv: Integer;
  CheckFlag: Integer;
  locYear, locMonth, locDay: Word;
begin
  Result := False;
  if Length(SerialNo) < 12 then
    Exit;
  HardSerial := '';
  CheckSum := 0;
  CheckFlag := 0;

  locYear := 0;
  locMonth := 0;
  locDay := 0;
  for ChrIndex := 1 to 12 do
  begin
    HardSerialChar := Chr((StrToInt(SerialKey[ChrIndex]) * 5 + ChrIndex div 2)
      mod 16 + 65);
    HardSerial := HardSerial + HardSerialChar;

    CheckDiv := ABS(Ord(SerialNo[ChrIndex]) - Ord(HardSerialChar));
    if ChrIndex <= 10 then
    begin
      CheckSum := CheckSum + CheckDiv;
      if ChrIndex mod 3 = 1 then
        locYear := locYear + Trunc(IntPower(10, ChrIndex div 3)) * CheckDiv
      else
        if ChrIndex <= 3 then
          locMonth := locMonth + Trunc(IntPower(10, ChrIndex - 2)) * CheckDiv
        else
          if ChrIndex <= 6 then
            locDay := locDay + Trunc(IntPower(10, ChrIndex - 5)) * CheckDiv;
    end
    else
      CheckFlag := CheckFlag + Trunc(IntPower(10, ChrIndex - 11)) * CheckDiv;
  end;
  if CheckSum <> CheckFlag then
    Exit;
  try
    ExpDate := EncodeDate(locYear, locMonth, locDay);
  except
    ExpDate := 0;
  end;
  Result := True;
end;

end.