unit SkyPublic;
interface
uses
Windows,SysUtils,Classes,Controls,Dialogs,ShellApi,Menus,StdCtrls,
registry,Forms,Graphics,Math,DateUtils;
type
TQuarter = 1..4;
TChinaNumFormat = (cnfBig,cnfSmall,cnfArab);
TChinaBigFormat = (cbfFull,cbfBlank);
TNumChar=‘0‘..‘9‘;
TStringArray = array of string;
TCharSet = set of Char;
TFontRecord = record
CharSet:Byte;
Color:Integer;
Name:string;
Size:Integer;
Style:Byte;
PixelsPerInch:Integer;
Pitch:0..2;
Height:Integer;
end;
const
CR = #13;
LF = #10;
NumCharSet=[‘0‘..‘9‘];
NameCharSet = [‘A‘..‘Z‘,‘a‘..‘z‘,‘0‘..‘9‘,‘_‘];
var
MimaFileName:string;
PositionMima:array [0..2] of Integer = (91,92,93);
{*****************************类操作******************************}
{显示类及其继承信息函数}
function ShowClassName(Obj:TObject):string;
procedure GetClassInfos(Obj:TComponent;StrList:TStringList);
procedure SaveClassInfos(Obj:TComponent;FileName:string);
{*****************************文件操作******************************}
{建文件夹}
function CreateDirs(APath:string):Boolean;
{拷贝}
function FileCopy(From, Dest: string;S:Integer=0;Dialog:Boolean=True):Boolean;
{移动}
procedure FileMove(From, Dest: string);
{删除}
procedure FileDelete(ADirName: string);
{更名}
function FileRename(From, Dest: string):Boolean;
{***************************控件操作********************************}
{TStrings，在Combobox中添加或者删除一个字符串}
procedure StringsOperation(ComboBox:TComboBox;IsAdd:Boolean;No:string=‘‘);
{***************************日期操作********************************}
{返回头尾日期}
procedure GetHeadTailDate(const SelfDate:TDate;var HeadDate,TailDate:TDate);overload;
procedure GetHeadTailDate(const Year,Month:Integer;var HeadDate,TailDate:TDate);overload;
{返回一月有多少天}
function ReturnHowDay(const AYear,AMonth:word):Word;
{返回季度头尾日期}
procedure GetQuarter(AYear:Word;AQuarter:TQuarter;var HeadDate,TailDate:TDate);overload;
procedure GetQuarter(SelfDate:TDate;var HeadDate,TailDate:TDate);overload;
procedure GetAccYearMonth(ADate:TDateTime;var Y,M:Word);
{**************************字符串操作*******************************}
{**************************string Function*******************************}
{得到1个字符在字符串中的个数}
function GetCharNum(const Ch:Char; const Str: string):Integer;
{Ini字符串和String字符串互相转换}
function IniStrToStr(const Str: string): string;
function StrToIniStr(const Str: string): string;
{给字符串加一个‘\‘}
function AddBackSlash(const S: string): string;
{减少字符串的长度}
procedure DecStrLen(var S: string; DecBy: Integer);
{返回有回车换行的字符串Position位置所在的字符串}
function GetCurLine(const S: string; Position: Integer): string;
{返回给定字符串的内存分配大小}
function GetStrAllocSize(const S: string): Longint;
{ 得到字符串的基准数 }
function GetStrRefCount(const S: string): Longint;
{清除A中指定的字符}
function KillChars(const S: string; A: array of Char; CaseSensitive: Boolean):string;
{ 返回子字符串在字符串中最后一个位置 }
function LastPos(const SubStr, S: string): Integer;
{ 设置字符串的实际长度 }
procedure RealizeLength(var S: string);
{ 移去字符串末尾的‘\‘}
function RemoveBackSlash(const S: string): string;
{移去字符串空格}
function RemoveSpaces(const S: string): string;
{字符串取反}
function ReverseStr(const S: string): string;
{除去前后回车}
function TrimEnterLeft(S:string):string;
function TrimEnterRight(S:string):string;
function TrimEnter(S:string):string;
{******************************PChar Function***************************}
procedure StrGetCurLine(StartPos, CurPos: PChar; TotalLen: integer;
var LineStart: PChar; var LineLen: integer);
{ 返回最后一个指定字符串及其以后的字符 }
function StrLastPos(Str1, Str2: PChar): PChar;
{截取第一个指定字符串及其以后的字符,大小写不敏感}
function StrIPos(Str1, Str2: PChar): PChar;
{截取第一个指定字符及其以后的字符,大小写不敏感}
function StrIScan(Str: PChar; Chr: Char): PChar;
{ 字符串取反 }
procedure StrReverse(P: PChar);
{返回中文大写数字}
function GetChinaNum(Num:TNumChar;ChinaNumFormat:TChinaNumFormat=cnfBig):string;
{将数字变成中文大写}
function FloatToChinaBig(Num:Double;ChinaBigFormat:TChinaBigFormat=cbfFull;Blanks:Byte=0):string;
function FloatToChnStr(Value: Real; ClearZero: Boolean; full:Boolean=False): String;
{将数字变成英文}
function FloatToEnglish(Num:Double):string;
{日期用英文}
function DateToEng(ADate:TDate;th:Boolean=False):string;
{取得SQL日期字符串等}
function DateToSQLDateStr(ADate:TDateTime):string;
function StrToSQLDateStr(Str:string):string;
function TimeToSQLTimeStr(ATime:TDateTime):string;
function StrToSQLTimeStr(Str:string):string;
function DateTimeToSQLDateTimeStr(ADateTime:TDateTime):string;
function StrToSQLDateTimeStr(Str:string):string;
{返回有逗号的金额字符串}
function FloatToMoneyStr(Num:Double;const HasSymbol:Boolean=False):string;
{Bool与字符串的转换}
function StrToBool(const Str:string):Boolean;
function BoolToStr(const Bool:Boolean):string;
{判断是否日期等}
function IsDate(const CheckString:string):Boolean;
function IsDateTime(const CheckString:string):Boolean;
function IsTime(const CheckString:string):Boolean;
function IsInteger(const CheckString:string):Boolean;
function IsFloat(const CheckString:string):Boolean;
{多字符串ShowMessage}
procedure ShowMessages(const Strings:array of string);
{新名称}
function NameToNewName(const Str:string):string;
{FloatTo%百分比}
function FloatToRate(Num:Double;Pos:Word):string;
{字体存贮}
procedure FontRecordToFont(FontRecord:TFontRecord;Font:TFont);
function FontToFontRecord(Font:TFont):TFontRecord;
function FontStylesToInt(FontStyles:TFontStyles):Byte;
function IntToFontStyles(FontInteger:Byte):TFontStyles;
{****************************数学*********************************}
{n次方}
function Power(X,Y:Extended):Extended;
{N的阶层}
function Order(N: Word): Extended;//（用Pascal写的N的阶层）
{得到小数点位数}
function GetFloatPointNum(Fl:Double):Integer;
{小数点位数，四舍五入法}
function FloatToNewFloat(AValue:Double):Double;
function FloatToNewFloatN(AValue:Double;N:Word=4):Double;
{******************************系统操作*******************************}
{关闭计算机}
function WinExit (iFlags: integer) : Boolean;
{防止开启多个应用程序}
procedure PreventMany(Name:string);
{得到应用程序的路径}
function GetApplicationDir(AppName:string):string;
{加到启动}
function RegAddToRun(Name,Value:string):Boolean;
procedure DeleteOneItem(Name:string);
{得到Delphi路径}
function GetDelphiDir:string;
{得到系统路径}
function GetSystemDir:string;
{得到windows路径}
function GetWindowsDir:string;
{得到计算机名}
function GetComputerNameD:string;
{设置计算机名}
function SetComputerNameD(Name:string):Boolean;
{执行一个文件}
function ExecuteFile(const FileName, Params, DefaultDir: string;
ShowCmd: Integer): THandle;
implementation
{显示类及其继承信息函数}
function ShowClassName(Obj:TObject):string;
var
Str:string;
K:TClass;
begin
K:=Obj.ClassType;
while not K.ClassNameIs(‘TObject‘) do
begin
Str:=K.ClassParent.ClassName+‘——>‘+Str;
K:=K.ClassParent;
end;
Result:=Str+Obj.ClassName;
end;
procedure GetClassInfos(Obj:TComponent;StrList:TStringList);
var
i:Integer;
S:string;
begin
StrList.Clear;
for I:=0 to Obj.ComponentCount-1 do
begin
S:=‘类名：‘+Obj.Components.ClassName+‘ ‘+‘名称：‘+Obj.Components.Name;
StrList.Add(S);
end;
end;
procedure SaveClassInfos(Obj:TComponent;FileName:string);
var
i:Integer;
S:string;
StrList:TStringList;
begin
StrList:=TStringList.Create;
try
for I:=0 to Obj.ComponentCount-1 do
begin
S:=‘类名：‘+Obj.Components.ClassName+‘ ‘+‘名称：‘+Obj.Components.Name;
StrList.Add(S);
end;
StrList.SaveToFile(FileName);
finally
StrList.Free;
end;
end;
{建文件夹}
function CreateDirs(APath:string):Boolean;
var
CurrentPath:string;
UsePath:string;
begin
CurrentPath:=GetCurrentDir;
UsePath:=Trim(APath);
if Pos(‘\‘,UsePath)=1 then
begin
UsePath:=Copy(CurrentPath,1,2)+UsePath;
end
else if Pos(‘:‘,UsePath)<>2 then UsePath:=CurrentPath+‘\‘+UsePath;
Result:=ForceDirectories(UsePath);
end;
{拷贝}{0:如果有同文件名则改名。1：如果同文件名则覆盖。}
function FileCopy(From, Dest: string;S:Integer=0;Dialog:Boolean=True):Boolean;
var
T: TSHFileOpStruct;
FromDir:PChar;
ToDir:PChar;
begin
GetMem(FromDir,Length(From)+2);
try
GetMem(ToDir,Length(Dest)+2);
try
FillChar(FromDir^,Length(From)+2,0);
FillChar(ToDir^,Length(Dest)+2,0);
StrCopy(FromDir,PChar(From));
StrCopy(ToDir,PChar(Dest));
with T do
begin
Wnd :=0;
wFunc :=FO_COPY;
pFrom :=FromDir;
pTo :=ToDir;
if S=0 then
fFlags :=FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION
else fFlags :=FOF_NOCONFIRMATION;
if not Dialog then
fFlags:=fFlags or FOF_SILENT;
fAnyOperationsAborted:=False;
hNameMappings:=nil;
lpszProgressTitle:=nil;
if SHFileOperation(T)=0 then
Result:=True
else Result:=False;
end;
finally
FreeMem(ToDir,Length(Dest)+2);
end;
finally
FreeMem(FromDir,Length(From)+2);
end;
end;
{移动}
procedure FileMove(From, Dest: string);
var
T: TSHFileOpStruct;
FromDir:PChar;
ToDir:PChar;
begin
GetMem(FromDir,Length(From)+2);
try
GetMem(ToDir,Length(Dest)+2);
try
FillChar(FromDir^,Length(From)+2,0);
FillChar(ToDir^,Length(Dest)+2,0);
StrCopy(FromDir,PChar(From));
StrCopy(ToDir,PChar(Dest));
with T do
begin
Wnd :=0;
wFunc :=FO_MOVE;
pFrom :=FromDir;
pTo :=ToDir;
fFlags :=FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:=False;
hNameMappings:=nil;
lpszProgressTitle:=nil;
if SHFileOperation(T)<>0 then
raise Exception.Create(‘移动文件操作不成功！‘);
end;
finally
FreeMem(ToDir,Length(Dest)+2);
end;
finally
FreeMem(FromDir,Length(From)+2);
end;
end;
{删除}
procedure FileDelete(ADirName: string);
var
SHFileOpStruct:TSHFileOpStruct;
DirName:PChar;
begin
Getmem(DirName,Length(ADirName)+2);
try
FillChar(Dirname^,Length(ADirName)+2,0);
StrCopy(DirName,PChar(ADirName));
with SHFileOpStruct do
begin
Wnd:=0;
wFunc:=FO_DELETE;
pFrom:=DirName;
pTo:=nil;
fFlags :=FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted:=False;
hNameMappings:=nil;
lpszProgressTitle:=nil;
end;
if SHfileOperation(SHFileOpStruct)<>0 then
raise Exception.Create(‘删除文件操作不成功！‘);
finally
FreeMem(DirName,Length(ADirName)+2);
end;
end;
{更名}
function FileRename(From, Dest: string):Boolean;
//var
// T: TSHFileOpStruct;
// FromDir:PChar;
// ToDir:PChar;
// FromDirectory,DestDirectory:string;
begin
Dest:=ExtractFileName(Dest);
Result:=RenameFile(From,Dest);
end;
{得到应用程序的路径}
function GetApplicationDir(AppName:string):string;
var
AppPath:string;
reg:TRegistry;
Name:string;
ExtName:string;
begin
ExtName:=Copy(AppName,Length(AppName)-3,4);
if ExtName[1]<>‘.‘ then AppName:=AppName+‘.exe‘;
Name:=‘Software\Microsoft\Windows\CurrentVersion\App Paths\‘+AppName;
reg:=TRegistry.Create;
try
reg.RootKey:=HKEY_LOCAL_MACHINE;
reg.OpenKey(Name,False);
AppPath:=reg.ReadString(‘path‘);
AppPath:=AddBackSlash(AppPath);
reg.CloseKey;
finally
reg.Free;
end;
Result:=AppPath;
end;
{加到启动}
function RegAddToRun(Name,Value:string):Boolean;
var
Reg:TRegistry;
Values:string;
begin
Result:=False;
Reg:=TRegistry.Create;
try
Reg.RootKey:=HKEY_LOCAL_MACHINE;
Reg.OpenKey(‘software\microsoft\windows\currentversion\run\‘,False);
Values:=Reg.ReadString(Name);
if Values<>Value then
begin
Reg.WriteString(Name,Value);
Result:=True;
end;
finally
Reg.Free;
end;
end;
procedure DeleteOneItem(Name:string);
var
Reg:TRegistry;
begin
Reg:=TRegistry.Create;
try
Reg.RootKey:=HKEY_LOCAL_MACHINE;
Reg.OpenKey(‘software\microsoft\windows\currentversion\run\‘,False);
if Reg.ValueExists(Name) then
Reg.DeleteValue(Name)
finally
Reg.Free;
end;
end;
{得到delphi路径}
function GetDelphiDir:string;
begin
Result:=GetApplicationDir(‘Delphi32.exe‘);
end;
{得到系统路径}
function GetSystemDir:string;
var
Buffer: array[0..MAX_PATH - 1] of Char;
begin
SetString(Result, Buffer, GetSystemDirectory(Buffer,SizeOf(Buffer)));
end;
{得到windows路径}
function GetWindowsDir:string;
var
Buffer: array[0..MAX_PATH - 1] of Char;
begin
SetString(Result, Buffer, GetWindowsDirectory(Buffer,SizeOf(Buffer)));
end;
{得到计算机名}
function GetComputerNameD:string;
var
Buffer: array[0..MAX_COMPUTERNAME_LENGTH] of Char;
BSize:Cardinal;
begin
BSize:=SizeOf(Buffer);
if GetComputerName(Buffer,BSize) then
begin
Result:=Buffer;
end
else Result:=‘‘;
end;
{设置计算机名}
function SetComputerNameD(Name:string):Boolean;
begin
if Length(Name)>MAX_COMPUTERNAME_LENGTH then
Name:=Copy(Name,1,MAX_COMPUTERNAME_LENGTH);
Result:=False;
if SetComputerName(PChar(Name)) then
Result:=True;
end;
function ExecuteFile(const FileName, Params, DefaultDir: string;
ShowCmd: Integer): THandle;
var
zFileName, zParams, zDir: array[0..120] of Char;
begin
Result := ShellExecute(Application.MainForm.Handle, nil,
StrPCopy(zFileName, FileName), StrPCopy(zParams, Params),
StrPCopy(zDir, DefaultDir), ShowCmd);
end;
{返回头尾日期}
procedure GetHeadTailDate(const SelfDate:TDate;var HeadDate,TailDate:TDate);overload;
const
AHeadDay=1;
var
AYear,AMonth,ATailDay,ASelfDay:Word;
begin
DecodeDate(SelfDate,AYear,AMonth,ASelfDay);
ATailDay:=ReturnHowDay(AYear,AMonth);
HeadDate:=EncodeDate(AYear,AMonth,AHeadDay);
TailDate:=EncodeDate(AYear,AMonth,ATailDay);
end;
procedure GetHeadTailDate(const Year,Month:Integer;var HeadDate,TailDate:TDate);overload;
const
HeadDay=1;
var
TailDay:Word;
begin
TailDay:=ReturnHowDay(Year,Month);
HeadDate:=EncodeDate(Year,Month,HeadDay);
TailDate:=EncodeDate(Year,Month,TailDay);
end;
{返回一月有多少天}
function ReturnHowDay(const AYear,AMonth:word):Word;
begin
case AMonth of
1,3,5,7,8,10,12:Result:=31;
4,6,9,11:Result:=30;
2:begin
if IsLeapYear(AYear) then
Result:=29
else Result:=28;
end;
else Result:=0;
end;
end;
{返回季度头尾日期}
procedure GetQuarter(AYear:Word;AQuarter:TQuarter;var HeadDate,TailDate:TDate);overload;
var
AHeadDate,ATailDate:TDate;
HeadMonth,TailMonth:Word;
begin
HeadMonth:=1;
TailMonth:=1;
case AQuarter of
1:begin
HeadMonth:=1;
TailMonth:=3;
end;
2:begin
HeadMonth:=4;
TailMonth:=6;
end;
3:begin
HeadMonth:=7;
TailMonth:=9;
end;
4:begin
HeadMonth:=10;
TailMonth:=12;
end;
end;
GetHeadTailDate(AYear,HeadMonth,AHeadDate,ATailDate);
HeadDate:=AHeadDate;
GetHeadTailDate(AYear,TailMonth,AHeadDate,ATailDate);
TailDate:=ATailDate;
end;
procedure GetQuarter(SelfDate:TDate;var HeadDate,TailDate:TDate);overload;
var
AYear,AMonth,ADay:Word;
AQuarter:TQuarter;
begin
AQuarter:=1;
DecodeDate(SelfDate,AYear,AMonth,ADay);
case AMonth of
1..3:AQuarter:=1;
4..6:AQuarter:=2;
7..9:AQuarter:=3;
10..12:AQuarter:=4;
end;
GetQuarter(AYear,AQuarter,HeadDate,TailDate);
end;
procedure GetAccYearMonth(ADate:TDateTime;var Y,M:Word);
var
D:Word;
begin
DecodeDate(ADate,Y,M,D);
if M=1 then
begin
Y:=Y-1;
M:=12;
end
else begin
M:=M-1;
end;
end;
{ *** Pascal string functions *** }
function GetCharNum(const Ch:Char; const Str: string):Integer;
var
S:PChar;
begin
S:=PChar(Str);
Result:=0;
while S^<>#0 do
begin
if S^=Ch then
Inc(Result);
Inc(S);
end;
end;
function IniStrToStr(const Str: string): string;
var
Buffer: array[0..4095] of Char;
B, S: PChar;
begin
if Length(Str) > SizeOf(Buffer) then
raise Exception.Create(‘String to read from an INI file‘);
S := PChar(Str);
B := Buffer;
while S^ <> #0 do
if (S[0] = ‘\‘) and (S[1] = ‘n‘) then
begin
B^ := #13;
Inc(B);
B^ := #10;
Inc(B);
Inc(S);
Inc(S);
end
else
begin
B^ := S^;
Inc(B);
Inc(S);
end;
B^ := #0;
Result := Buffer;
end;
function StrToIniStr(const Str: string): string;
var
Buffer: array[0..4095] of Char;
B, S: PChar;
begin
if Length(Str) > SizeOf(Buffer) then
raise Exception.Create(‘String to large to save in INI file‘);
S := PChar(Str);
B := Buffer;
while S^ <> #0 do
case S^ of
#13, #10:
begin
if (S^ = #13) and (S[1] = #10) then Inc(S)
else if (S^ = #10) and (S[1] = #13) then Inc(S);
B^ := ‘\‘;
Inc(B);
B^ := ‘n‘;
Inc(B);
Inc(S);
end;
else
B^ := S^;
Inc(B);
Inc(S);
end;
B^ := #0;
Result := Buffer;
end;
function AddBackSlash(const S: string): string;
begin
Result := S;
if S<>‘‘ then
begin
if Result[Length(Result)] <> ‘\‘ then // if last char isn‘t a backslash...
Result := Result + ‘\‘; // make it so
end;
end;
procedure DecStrLen(var S: string; DecBy: Integer);
begin
SetLength(S, Length(S) - DecBy); // decrement string length by DecBy
end;
function GetCurLine(const S: string; Position: Integer): string;
var
ResP: PChar;
ResLen: integer;
begin
StrGetCurLine(PChar(S), PChar(Longint(S) + Position - 1), Length(S), ResP,
ResLen);
SetString(Result, ResP, ResLen);
end;
function GetStrAllocSize(const S: string): Longint;
var
P: ^Longint;
begin
P := Pointer(S); // pointer to string structure
dec(P, 3); // 12-byte negative offset
Result := P^ and not $80000000 shr 1; // ignore bits 0 and 31
end;
function GetStrRefCount(const S: string): Longint;
var
P: ^Longint;
begin
P := Pointer(S); // pointer to string structure
dec(P, 2); // 8-byte negative offset
Result := P^;
end;
function KillChars(const S: string; A: array of Char; CaseSensitive: Boolean):
string;
var
CharSet: TCharSet;
i, count: integer;
begin
CharSet := []; // empty character set
for i := Low(A) to High(A) do begin
Include(CharSet, A); // fill set with array items
if not CaseSensitive then begin // if not case sensitive, then also
if A in [‘A‘..‘Z‘] then
Include(CharSet, Chr(Ord(A) + 32)) // include lower cased or
else if A in [‘a‘..‘z‘] then
Include(CharSet, Chr(Ord(A) - 32)) // include upper cased character
end;
end;
SetLength(Result, Length(S)); // set length to prevent realloc
count := 0;
for i := 1 to Length(S) do begin // iterate over string S
if not (S in CharSet) then begin // add good chars to Result
Result[count + 1] := S;
inc(Count); // keep track of num chars copies
end;
end;
SetLength(Result, count); // set length to num chars copied
end;
function LastPos(const SubStr, S: string): Integer;
var
FoundStr: PChar;
begin
Result := 0;
FoundStr := StrLastPos(PChar(S), PChar(SubStr));
if FoundStr <> nil then
Result := (Cardinal(Length(S)) - StrLen(FoundStr)) + 1;
end;
procedure RealizeLength(var S: string);
begin
SetLength(S, StrLen(PChar(S)));
end;
function RemoveBackSlash(const S: string): string;
begin
Result := S;
if Result[Length(Result)] = ‘\‘ then // if last character is a backslash...
DecStrLen(Result, 1); // decrement string length
end;
function RemoveSpaces(const S: string): string;
begin
Result := KillChars(S, [‘ ‘], True);
end;
function ReverseStr(const S: string): string;
begin
Result := S;
StrReverse(PChar(Result));
end;
{除去前后回车}
function TrimEnterLeft(S:string):string;
begin
S:=ReverseStr(S);
S:=TrimEnterRight(S);
S:=ReverseStr(S);
Result:=S;
end;
function TrimEnterRight(S:string):string;
begin
while ((Length(S)>1)and((S[Length(S)]=#10)and(S[Length(S)-1]=#13)))or
((Length(S)>1)and((S[Length(S)]=#13)and(S[Length(S)-1]=#10))) do
begin
S:=Copy(S,1,Length(S)-2);
end;
Result:=S;
end;
function TrimEnter(S:string):string;
begin
S:=TrimE
{将数字变成中文大写}
function FloatToChinaBig(Num:Double;ChinaBigFormat:TChinaBigFormat=cbfFull;Blanks:Byte=0):string;
var
Str:string;
AgainstStr:string;
NumStr:string;
i,j:Integer;
AllNumLength:Integer;
TempStr:string;
begin
if Blanks>15 then Blanks:=17;
NumStr:=CurrToStrF(Num,ffFixed,2);
Delete(NumStr,Pos(‘.‘,NumStr),1);
AllNumLength:=Length(NumStr);
if Blanks<=AllNumLength then Blanks:=AllNumLength
else begin
TempStr:=‘‘;
for i:=1 to Blanks-AllNumLength do
begin
TempStr:=TempStr+‘0‘;
end;
NumStr:=TempStr+NumStr;
end;
NumStr:=ReverseStr(NumStr);
Str:=FormatFloat(‘0佰0拾0万0仟0佰0拾0亿0仟0佰0拾0万0仟0佰0拾0圆.0角0分‘,Num);
Delete(Str,Pos(‘.‘,Str),1);
AgainstStr:=ReverseStr(Str);
AgainstStr:=Copy(AgainstStr,1,3*Blanks);
if ChinaBigFormat=cbfBlank then
begin
AgainstStr:=‘‘;
for i:=1 to Blanks do
AgainstStr:=AgainstStr+‘ ‘+NumStr;
end;
j:=0;
for i:=1 to Blanks do
begin
Insert(ReverseStr(GetChinaNum(AgainstStr[3*i+2*j])),AgainstStr,3*i+2*j);
Inc(j);
end;
j:=0;
for i:=1 to Blanks do
begin
Delete(AgainstStr,5*i-j,1);
Inc(j);
end;
Result:=ReverseStr(AgainstStr);
end;
function FloatToChnStr(Value: Real; ClearZero: Boolean; full:Boolean=False): String;
const
ChnUnit: array[0..13] of string = (‘分‘, ‘角‘, ‘元‘, ‘拾‘, ‘佰‘, ‘仟‘, ‘万‘, ‘拾‘, ‘佰‘, ‘仟‘, ‘亿‘, ‘拾‘, ‘佰‘, ‘仟‘);
ChnNum : array[0..9] of string = (‘零‘, ‘壹‘,‘贰‘, ‘叁‘, ‘肆‘, ‘伍‘, ‘陆‘, ‘柒‘, ‘捌‘, ‘玖‘);
var
I: Integer;
StrValue, StrNum: String;
ValueLen: Integer;
begin
if Value <= 0 then
begin
Result := ‘输入参数应大于零。‘;
Exit;
end;
value:=RoundTo(Value,-2);
StrValue := IntToStr(Round(Value * 100));
ValueLen := Length(StrValue);
Result := ‘‘;
for I := 1 to ValueLen do
begin
StrNum := StrValue;
Result := Result + ChnNum[StrToInt(StrNum)] + ChnUnit[ValueLen - I];
end;
if ClearZero then
begin
Result := StringReplace(Result, ‘零分‘, ‘‘, [rfReplaceAll]);
if Frac(Value)>0.009999 then
Result := StringReplace(Result, ‘零角‘, ‘零‘, [rfReplaceAll])
else
Result := StringReplace(Result, ‘零角‘, ‘‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零元‘, ‘元‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零拾‘, ‘零‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零佰‘, ‘零‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零仟‘, ‘零‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零万‘, ‘万‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零零‘, ‘零‘, [rfReplaceAll]);
Result := StringReplace(Result, ‘零零‘, ‘零‘, [rfReplaceAll]);
end;
if full then
begin
if Frac(Value)<0.009999 then
Result:=Result+‘整‘;
end;
end;
{将数字变成英文}
function FloatToEnglish(Num:Double):string;
var
StrList:TStringList;
i:Integer;
StrTemp1,StrTemp2:String;
NumArray:array [0..3] of Integer;
NumCount:Integer;
ResultStr:string;
Tmp,Tmp1,Tmp2,TmpXiao:Integer;
function OneNumToEng(Num:Integer;TWO:Integer=0):string;
begin
if Two=0 then
begin
case Num of
0:Result:=‘ZERO‘;
1:Result:=‘ONE‘;
2:Result:=‘TWO‘;
3:Result:=‘THREE‘;
4:Result:=‘FOUR‘;
5:Result:=‘FIVE‘;
6:Result:=‘SIX‘;
7:Result:=‘SEVEN‘;
8:Result:=‘EIGHT‘;
9:Result:=‘NINE‘;
end;
end
else if Two=1 then
begin
case Num of
1:Result:=‘TEN‘;
2:Result:=‘TWENTY‘;
3:Result:=‘THIRTY‘;
4:Result:=‘FORTY‘;
5:Result:=‘FIFTY‘;
6:Result:=‘SIXTY‘;
7:Result:=‘SEVENTY‘;
8:Result:=‘EIGHTY‘;
9:Result:=‘NINETY‘;
end;
end
else if Two=2 then
begin
case Num of
0:Result:=‘‘;
1:Result:=‘ONE‘;
2:Result:=‘TWO‘;
3:Result:=‘THREE‘;
4:Result:=‘FOUR‘;
5:Result:=‘FIVE‘;
6:Result:=‘SIX‘;
7:Result:=‘SEVEN‘;
8:Result:=‘EIGHT‘;
9:Result:=‘NINE‘;
end;
end;
end;
function TwoNumToEng(Num:Integer):string;
var
NStr:string;
One:string;
Two:string;
S:string;
begin
NStr:=IntToStr(Num);
if Num<10 then
Result:=OneNumToEng(Num)
else begin
case Num of
10:Result:=‘TEN‘;
11:Result:=‘ELEVEN‘;
12:Result:=‘TWELVE‘;
13:Result:=‘THIRTEEN‘;
14:Result:=‘FOURTEEN‘;
15:Result:=‘FIFTEEN‘;
16:Result:=‘SIXTEEN‘;
17:Result:=‘SEVENTEEN‘;
18:Result:=‘EIGHTEEN‘;
19:Result:=‘NINETEEN‘;
20:Result:=‘TWENTY‘;
30:Result:=‘THIRTY‘;
40:Result:=‘FORTY‘;
50:Result:=‘FIFTY‘;
60:Result:=‘SIXTY‘;
70:Result:=‘SEVENTY‘;
80:Result:=‘EIGHTY‘;
90:Result:=‘NINETY‘;
else begin
One:=NStr[1];
Two:=NStr[2];
S:=OneNumToEng(StrToInt(One),1);
S:=S+‘-‘+OneNumToEng(StrToInt(Two),2);
Result:=S;
end;
end;
end;
end;
function ThreeNumToEng(Num:Integer;Hasand:Boolean=False):string;
var
Nstr:string;
S:string;
H:Integer;
R:Integer;
begin
Nstr:=IntToStr(Num);
if Num>=100 then
begin
H:=Num div 100;
R:=Num mod 100;
if R=0 then
begin
S:=OneNumToEng(H)+‘ ‘+‘HUNDRED‘;
end
else begin
S:=OneNumToEng(H)+‘ ‘+‘HUNDRED‘+‘ AND ‘+TwoNumToEng(R);
end;
end
else begin
S:=TwoNumToEng(Num);
end;
if Hasand then
begin
if S=‘ZERO‘ then
Result:=‘‘ else
Result:=‘AND ‘+S
end
else Result:=S;
end;
begin
{0 nought;zero;O
1 one
2 two
3 three
4 four
5 five
6 six
7 seven
8 eight
9 nine
10 ten
11 eleven
12 twelve
13 thirteen
14 fourteen
15 fifteen
16 sixteen
17 seventeen
18 eighteen
19 nineteen
20 twenty
21 twenty-one
22 twenty-two
23 twenty-three
30 thirty
32 thirty-two
40 forty
50 fifty
60 sixty
70 seventy
80 eighty
90 ninety
100 one hundred
101 one hundred and one
156 one hundred and fifty-six
192 one hundred and ninety-two
200 two hundred
300 three hundred
400 four hundred
500 five hundred
600 six hundred
700 seven hundred
800 eight hundred
900 nine hundred
1,000 one thousand
1,001 one thousand and one
1,300 thirteen hundred;one thousand and three hundred
2,000 two thousand
2,034 two thousand and thirty-four
6,502 six thousand five hundred and two
38,000 thirty-eight thousand
45,672 forty-five thousand six hundred and seventy-two
500,000 five hundred thousand
1,000,000 one million
3,123,400 three million,one hundred and twenty-three thousand and four hundred
8,000,000 eight million
47,000,000 forty-seven million
900,000,000 nine hundred million
1,000,000,000 a milliard,one milliard(美作:a billion,one billion)
1,050,000,000 one billion and fifty million
10,000,000,000 ten billion
200,000,000,000 two hundred billion
1,000,000,000,000 a billion,one billion(美作:a trillion,one trillion)
6,000,000,000,000 six million million}
if Num>2000000000 then Raise Exception.Create(‘数值太大‘);
StrList:=TStringList.Create;
try
Tmp:=Trunc(Num);
TmpXiao:=Round((Num-Tmp)*100);
// ShowMessage(IntToStr(Tmpxiao));
Tmp1:=Tmp div 1000;
Tmp2:=Tmp mod 1000;
while Tmp1>0 do
begin
Tmp:=Tmp1;
StrList.Add(IntToStr(Tmp2));
Tmp1:=Tmp div 1000;
Tmp2:=Tmp mod 1000;
end;
StrList.Add(IntToStr(Tmp2));
NumCount:=StrList.Count;
for i:=0 to NumCount-1 do
begin
NumArray:=StrToInt(StrList);
end;
case NumCount of
1:ResultStr:=ThreeNumToEng(NumArray[0]);
2:ResultStr:=ThreeNumToEng(NumArray[1])+‘ THOUSAND ‘+ThreeNumToEng(NumArray[0],True);
3:begin
StrTemp1:=ThreeNumToEng(NumArray[1],True);
if StrTemp1<>‘‘ then
ResultStr:=ThreeNumToEng(NumArray[2])+‘ MILLION ‘+
StrTemp1+‘ THOUSAND ‘+
ThreeNumToEng(NumArray[0],True)
else ResultStr:=ThreeNumToEng(NumArray[2])+‘ MILLION ‘+
ThreeNumToEng(NumArray[0],True);
end;
4:begin
StrTemp2:=ThreeNumToEng(NumArray[3])+‘ BILLION ‘;
StrTemp1:=ThreeNumToEng(NumArray[2],True);
if StrTemp1<>‘‘ then
StrTemp2:=StrTemp2+StrTemp1;
StrTemp1:=ThreeNumToEng(NumArray[1],True);
if StrTemp1<>‘‘ then
StrTemp2:=StrTemp2+StrTemp1;
ResultStr:=StrTemp2+ThreeNumToEng(NumArray[0],True);
end;
end;
StrTemp1:=ThreeNumToEng(TmpXiao,True);
if StrTemp1<>‘‘ then
ResultStr:=ResultStr+‘ AND CENTS ‘+Copy(StrTemp1,5,Length(StrTemp1)-4);
Result:=ResultStr;
finally
StrList.Free;
end;
end;
{日期用英文}
function DateToEng(ADate:TDate;th:Boolean=False):string;
var
AYear,AMonth,ADay:Word;
SYear,SMonth,SDay:string;
begin
DecodeDate(ADate,AYear,AMonth,ADay);
case AMonth of
1:SMonth:=‘JAN‘;
2:SMonth:=‘FEB‘;
3:SMonth:=‘MAR‘;
4:SMonth:=‘APR‘;
5:SMonth:=‘MAY‘;
6:SMonth:=‘JUN‘;
7:SMonth:=‘JUL‘;
8:SMonth:=‘AUG‘;
9:SMonth:=‘SEP‘;
10:SMonth:=‘OCT‘;
11:SMonth:=‘NOV‘;
12:SMonth:=‘DEC‘;
end;
SDay:=IntToStr(ADay);
if th then
begin
case ADay of
1,21,31:SDay:=SDay+‘st‘;
2,22,23:SDay:=SDay+‘nd‘;
3:SDay:=SDay+‘rd‘;
4..20:SDay:=SDay+‘th‘;
24..30:SDay:=SDay+‘st‘;
end;
end;
SYear:=IntToStr(AYear);
Result:=SMonth+‘ ‘+SDay+‘,‘+SYear;
end;
{字符串取反}
{function GetAgainstStr(Str:string):string;
var
i,StrLength:Integer;
TmpStr:string;
begin
StrLength:=Length(Str);
SetLength(TmpStr,StrLength);
for i:=1 to StrLength do TmpStr:=Str[StrLength+1-i];
Result:=TmpStr;
end;}
{取得SQL日期字符串}
function DateToSQLDateStr(ADate:TDateTime):string;
begin
Result:=FormatDateTime(‘mm"/"dd"/"yyyy‘,ADate);
end;
function StrToSQLDateStr(Str:string):string;
var
StrDate:TDateTime;
begin
StrDate:=StrToDateTime(Str);
Result:=DateToSQLDateStr(StrDate);
end;
function TimeToSQLTimeStr(ATime:TDateTime):string;
begin
Result:=FormatDateTime(‘hh":"nn":"ss‘,ATime);
end;
function StrToSQLTimeStr(Str:string):string;
var
StrTime:TDateTime;
begin
StrTime:=StrToDateTime(Str);
Result:=TimeToSQLTimeStr(StrTime);
end;
function DateTimeToSQLDateTimeStr(ADateTime:TDateTime):string;
begin
Result:=FormatDateTime(‘mm"/"dd"/"yyyy hh":"nn":"ss‘,ADateTime);
end;
function StrToSQLDateTimeStr(Str:string):string;
var
StrDateTime:TDateTime;
begin
StrDateTime:=StrToDateTime(Str);
Result:=DateTimeToSQLDateTimeStr(StrDateTime);
end;
{返回有逗号的金额字符串}
function FloatToMoneyStr(Num:Double;const HasSymbol:Boolean=False):string;
begin
if HasSymbol then Result:=CurrToStrF(Num,ffCurrency,2)
else Result:=CurrToStrF(Num,ffNumber,2);
end;
{Bool与字符串的转换}
function StrToBool(const Str:string):Boolean;
begin
if CompareText(‘True‘,Str)=0 then Result:=True
else Result:=False;
end;
function BoolToStr(const Bool:Boolean):string;
begin
if Bool then Result:=‘True‘
else Result:=‘False‘;
end;
{判断是否日期等}
type
TDateOrder = (doMDY, doDMY, doYMD);
function CurrentYear: Word;
var
SystemTime: TSystemTime;
begin
GetLocalTime(SystemTime);
Result := SystemTime.wYear;
end;
function DoEncodeTime(Hour, Min, Sec, MSec: Word; var Time: TDateTime): Boolean;
begin
Result := False;
if (Hour < 24) and (Min < 60) and (Sec < 60) and (MSec < 1000) then
begin
Time := (Hour * 3600000 + Min * 60000 + Sec * 1000 + MSec) / MSecsPerDay;
Result := True;
end;
end;
function DoEncodeDate(Year, Month, Day: Word; var Date: TDateTime): Boolean;
var
I: Integer;
DayTable: PDayTable;
begin
Result := False;
DayTable := @MonthDays[IsLeapYear(Year)];
if (Year >= 1) and (Year <= 9999) and (Month >= 1) and (Month <= 12) and
(Day >= 1) and (Day <= DayTable^[Month]) then
begin
for I := 1 to Month - 1 do Inc(Day, DayTable^);
I := Year - 1;
Date := I * 365 + I div 4 - I div 100 + I div 400 + Day - DateDelta;
Result := True;
end;
end;
procedure ScanBlanks(const S: string; var Pos: Integer);
var
I: Integer;
begin
I := Pos;
while (I <= Length(S)) and (S = ‘ ‘) do Inc(I);
Pos := I;
end;
function ScanNumber(const S: string; var Pos: Integer;
var Number: Word; var CharCount: Byte): Boolean;
var
I: Integer;
N: Word;
begin
Result := False;
CharCount := 0;
ScanBlanks(S, Pos);
I := Pos;
N := 0;
while (I <= Length(S)) and (S in [‘0‘..‘9‘]) and (N < 1000) do
begin
N := N * 10 + (Ord(S) - Ord(‘0‘));
Inc(I);
end;
if I > Pos then
begin
CharCount := I - Pos;
Pos := I;
Number := N;
Result := True;
end;
end;
function ScanString(const S: string; var Pos: Integer;
const Symbol: string): Boolean;
begin
Result := False;
if Symbol <> ‘‘ then
begin
ScanBlanks(S, Pos);
if AnsiCompareText(Symbol, Copy(S, Pos, Length(Symbol))) = 0 then
begin
Inc(Pos, Length(Symbol));
Result := True;
end;
end;
end;
function ScanChar(const S: string; var Pos: Integer; Ch: Char): Boolean;
begin
Result := False;
ScanBlanks(S, Pos);
if (Pos <= Length(S)) and (S[Pos] = Ch) then
begin
Inc(Pos);
Result := True;
end;
end;
function GetDateOrder(const DateFormat: string): TDateOrder;
var
I: Integer;
begin
Result := doMDY;
I := 1;
while I <= Length(DateFormat) do
begin
case Chr(Ord(DateFormat) and $DF) of
‘E‘: Result := doYMD;
‘Y‘: Result := doYMD;
‘M‘: Result := doMDY;
‘D‘: Result := doDMY;
else
Inc(I);
Continue;
end;
Exit;
end;
Result := doMDY;
end;
procedure ScanToNumber(const S: string; var Pos: Integer);
begin
while (Pos <= Length(S)) and not (S[Pos] in [‘0‘..‘9‘]) do
begin
if S[Pos] in LeadBytes then Inc(Pos);
Inc(Pos);
end;
end;
function GetEraYearOffset(const Name: string): Integer;
var
I: Integer;
begin
Result := 0;
for I := Low(EraNames) to High(EraNames) do
begin
if EraNames = ‘‘ then Break;
if AnsiStrPos(PChar(EraNames), PChar(Name)) <> nil then
begin
Result := EraYearOffsets;
Exit;
end;
end;
end;
function ScanDate(const S: string; var Pos: Integer;
var Date: TDateTime): Boolean;
var
DateOrder: TDateOrder;
N1, N2, N3, Y, M, D: Word;
L1, L2, L3, YearLen: Byte;
EraName : string;
EraYearOffset: Integer;
CenturyBase: Integer;
function EraToYear(Year: Integer): Integer;
begin
if SysLocale.PriLangID = LANG_KOREAN then
begin
if Year <= 99 then
Inc(Year, (CurrentYear + Abs(EraYearOffset)) div 100 * 100);
if EraYearOffset > 0 then
EraYearOffset := -EraYearOffset;
end
else
Dec(EraYearOffset);
Result := Year + EraYearOffset;
end;
begin
Y := 0;
M := 0;
D := 0;
YearLen := 0;
Result := False;
DateOrder := GetDateOrder(ShortDateFormat);
EraYearOffset := 0;
if ShortDateFormat[1] = ‘g‘ then // skip over prefix text
begin
ScanToNumber(S, Pos);
EraName := Trim(Copy(S, 1, Pos-1));
EraYearOffset := GetEraYearOffset(EraName);
end
else
if AnsiPos(‘e‘, ShortDateFormat) > 0 then
EraYearOffset := EraYearOffsets[1];
if not (ScanNumber(S, Pos, N1, L1) and ScanChar(S, Pos, DateSeparator) and
ScanNumber(S, Pos, N2, L2)) then Exit;
if ScanChar(S, Pos, DateSeparator) then
begin
if not ScanNumber(S, Pos, N3, L3) then Exit;
case DateOrder of
doMDY: begin Y := N3; YearLen := L3; M := N1; D := N2; end;
doDMY: begin Y := N3; YearLen := L3; M := N2; D := N1; end;
doYMD: begin Y := N1; YearLen := L1; M := N2; D := N3; end;
end;
if EraYearOffset > 0 then
Y := EraToYear(Y)
else if (YearLen <= 2) then
begin
CenturyBase := CurrentYear - TwoDigitYearCenturyWindow;
Inc(Y, CenturyBase div 100 * 100);
if (TwoDigitYearCenturyWindow > 0) and (Y < CenturyBase) then
Inc(Y, 100);
end;
end else
begin
Y := CurrentYear;
if DateOrder = doDMY then
begin
D := N1; M := N2;
end else
begin
M := N1; D := N2;
end;
end;
ScanChar(S, Pos, DateSeparator);
ScanBlanks(S, Pos);
if SysLocale.FarEast and (System.Pos(‘ddd‘, ShortDateFormat) <> 0) then
begin // ignore trailing text
if ShortTimeFormat[1] in [‘0‘..‘9‘] then // stop at time digit
ScanToNumber(S, Pos)
else // stop at time prefix
repeat
while (Pos <= Length(S)) and (S[Pos] <> ‘ ‘) do Inc(Pos);
ScanBlanks(S, Pos);
until (Pos > Length(S)) or
(AnsiCompareText(TimeAMString, Copy(S, Pos, Length(TimeAMString))) = 0) or
(AnsiCompareText(TimePMString, Copy(S, Pos, Length(TimePMString))) = 0);
end;
Result := DoEncodeDate(Y, M, D, Date);
end;
function ScanTime(const S: string; var Pos: Integer;
var Time: TDateTime): Boolean;
var
BaseHour: Integer;
Hour, Min, Sec, MSec: Word;
Junk: Byte;
begin
Result := False;
BaseHour := -1;
if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, ‘AM‘) then
BaseHour := 0
else if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, ‘PM‘) then
BaseHour := 12;
if BaseHour >= 0 then ScanBlanks(S, Pos);
if not ScanNumber(S, Pos, Hour, Junk) then Exit;
Min := 0;
if ScanChar(S, Pos, TimeSeparator) then
if not ScanNumber(S, Pos, Min, Junk) then Exit;
Sec := 0;
if ScanChar(S, Pos, TimeSeparator) then
if not ScanNumber(S, Pos, Sec, Junk) then Exit;
MSec := 0;
if ScanChar(S, Pos, DecimalSeparator) then
if not ScanNumber(S, Pos, MSec, Junk) then Exit;
if BaseHour < 0 then
if ScanString(S, Pos, TimeAMString) or ScanString(S, Pos, ‘AM‘) then
BaseHour := 0
else
if ScanString(S, Pos, TimePMString) or ScanString(S, Pos, ‘PM‘) then
BaseHour := 12;
if BaseHour >= 0 then
begin
if (Hour = 0) or (Hour > 12) then Exit;
if Hour = 12 then Hour := 0;
Inc(Hour, BaseHour);
end;
ScanBlanks(S, Pos);
Result := DoEncodeTime(Hour, Min, Sec, MSec, Time);
end;
function IsDate(const CheckString:string):Boolean;
var
Pos: Integer;
Date:TDateTime;
begin
Pos := 1;
Result:=ScanDate(CheckString, Pos, Date) or (Pos <= Length(CheckString));
end;
function IsDateTime(const CheckString:string):Boolean;
var
Pos,Pos1: Integer;
Date, Time: TDateTime;
DateTime:TDateTime;
begin
Pos := 1;
Pos1:=1;
Time := 0;
Result:=ScanDate(CheckString,Pos,Date) or not ((Pos > Length(CheckString)) or
ScanTime(CheckString, Pos, Time)) or
(ScanTime(CheckString, Pos1, DateTime) or (Pos1 <= Length(CheckString)));
end;
function IsTime(const CheckString:string):Boolean;
var
Pos: Integer;
v:TDateTime;
begin
Pos := 1;
Result:=ScanTime(CheckString, Pos, v) or (Pos <= Length(CheckString))
end;
{$HINTS OFF}
function IsInteger(const CheckString:string):Boolean;
var
V,Code:Integer;
begin
Val(CheckString,V,Code);
Result := code = 0;
end;
{$HINTS ON}
function IsFloat(const CheckString:string):Boolean;
var
V:Extended;
begin
Result:=TextToFloat(PChar(CheckString), V, fvExtended);
end;
{多字符串ShowMessage}
procedure ShowMessages(const Strings:array of string);
var
i:Integer;
S:string;
begin
for i:=Low(Strings) to High(Strings) do
begin
S:=S+Strings+#13#10;
end;
ShowMessage(S);
end;
{新名称}
function NameToNewName(const Str:string):string;
var
StrPart,NumPart:string;
i,LengStr:Integer;
begin
LengStr:=Length(Str);
i:=LengStr;
if Str in [‘0‘..‘9‘] then
begin
NumPart:=Str+NumPart;
Dec(i);
while Str in [‘1‘..‘9‘] do
begin
NumPart:=Str+NumPart;
Dec(i);
end;
end;
StrPart:=Copy(Str,1,i);
if Length(NumPart)=0 then NumPart:=‘1‘
else NumPart:=IntToStr(StrToInt(NumPart)+1);
Result:=StrPart+NumPart;
end;