📄 strfuncs.pas
字号:
If (s[i] = '0') and (s[i-1] <> '0') then
result := result + s[i];
//验证亿位
If (w - i = 9) and (pos(GetCurrency(9), result) = 0) then
result := result + GetCurrency(9);
//验证万位
If (w - i = 5) and (pos(GetCurrency(5), result) = 0)
and (copy(s, w - 8, 4) <> '0000') then
result := result + GetCurrency(5);
end;
//假如结尾是零时
if result[length(result)]='0' then
Delete(result,length(result),1);
//假如是整数当返回值以点结尾
if (format in [INT_NUMERICAL_CHINESE_SIMPLE, INT_NUMERICAL_CHINESE_TRADITION])
and (w = length(s) + 1) and (RightStr(result) = GetCurrency(1)) then
Delete(Result, Length(Result)-1, 2);
//这一步是验证有没有以元或点结尾
If RightStr(result) <> GetCurrency(1) then
begin
// 如果要求返回值是一个金额时，直接加上元
// 如果要求返回值是一个数值时，先验证是否是一个整数，整数无须加上点
If ((w <> length(s) + 1) and
(format in [INT_NUMERICAL_CHINESE_SIMPLE, INT_NUMERICAL_CHINESE_TRADITION])) or
(format in [INT_CURRENCY_CHINESE_SIMPLE, INT_CURRENCY_CHINESE_TRADITION]) then
result := result + GetCurrency(1);
end;
//当是一个整数时
if (w = length(s) + 1) then
result := result + '整';
//这一步是转换小数点后的数值
for I := w+1 to length(s) do
begin
If (s[i] = '0') and (s[i-1] <> '0') then
result := result + s[i];
if s[i] <> '0' then
begin
result := result + s[i];
//当格式是钱币时, 必须处理单位
if (format in [1, 2]) then
result := result + copy('角分',(i-w)*2-1,2);
end;
end;
//这一步是将转换后的数值大写化并返回}
if (format in [INT_CURRENCY_CHINESE_SIMPLE, INT_NUMERICAL_CHINESE_SIMPLE]) then
result := NumberSwitch(result, INT_ARABIC_NUMERALS, INT_CHINESE_SIMPLE_NUMBER)
else result := NumberSwitch(result, INT_ARABIC_NUMERALS, INT_CHINESE_TRADITION_NUMBER);
if value < 0 then result := '负' + result;
end;
function StrStatistic(value : wideString): TStrInfo;
var
I : Integer;
begin
with Result do
begin
CharAmount := Length(value);
LowerCase := 0;
UpperCase := 0;
Blank := 0;
Tabs := 0;
Enter := 0;
CtrlChar := 0;
ArabicNumerals := 0;
UnicodeChar := 0;
AnsiChar := 0;
for I := 1 to Length(value) do
begin
// 判断是否单字节还是双字节
if (length(string(value[i])) = 1) then
Inc(AnsiChar)
else Inc(UnicodeChar);
// 判断是否是大写字母
If (value[i] >= 'A') and (value[i] <= 'Z') then
Inc(UpperCase);
// 判断是否是小写字母
If (value[i] >= 'a') and (value[i] <= 'z') then
Inc(LowerCase);
// 判断是否空格
If value[i] = #32 then
Inc(Blank);
// 判断是否回车换行符
If (i > 1) and (value[i - 1] = #13) and (value[i] = #10) then
Inc(Enter);
// 判断是否是制表符
If value[i] = #9 then
Inc(Tabs);
// 判断是否是控制字符
If (value[i] >= #0) and (value[i] <= #31) then
Inc(CtrlChar);
// 判断是否是数字
If (value[i] >= #48 ) and (value[I] <= #57) then
Inc(ArabicNumerals);
end;
end;
end;
function ExtractHtml(value :string):string;
const
CR=#13#10;
var
NextToken,s0 : string;
i:integer;
HelpIdx:integer;
inQuot:boolean; // 去除<script>段之用
InputLen:integer;
InputIdx:integer; // 指向输入字符的下一个待处理字符
inPre:boolean; // 表示是否在<pre>...</pre>段内
CurrLink:string;
function MakeStr(C: Char; N: Integer): string;
begin
if N < 1 then Result := ''
else begin
{$IFNDEF WIN32}
if N > 255 then N := 255;
{$ENDIF WIN32}
SetLength(Result, N);
FillChar(Result[1], Length(Result), C);
end;
end;
function NPos(const C: string; S: string; N: Integer): Integer;
var
I, P, K: Integer;
begin
Result := 0;
K := 0;
for I := 1 to N do
begin
P := Pos(C, S);
Inc(K, P);
if (I = N) and (P > 0) then
begin
Result := K;
Exit;
end;
if P > 0 then Delete(S, 1, P)
else Exit;
end;
end;
function ReplaceStr(const S, Srch, Replace: string): string;
var
I: Integer;
Source: string;
begin
Source := S;
Result := '';
repeat
I := Pos(Srch, Source);
if I > 0 then
begin
Result := Result + Copy(Source, 1, I - 1) + Replace;
Source := Copy(Source, I + Length(Srch), MaxInt);
end
else Result := Result + Source;
until I <= 0;
end;
function UnixToDos(const s:string):string;
begin
result:=AdjustLineBreaks(s);
end;
// 取得下一段字符串
function GetNextToken(const s:string; const StartIdx:integer):string;
var
i:integer;
begin
if StartIdx>length(s) then
begin
result:='';
exit;
end;
result:=s[StartIdx];
if result='&' then
begin
for i:=StartIdx+1 to length(s) do
begin
if s[i] in ['&',' ',#13,'<'] then break;
result:=result+s[i];
if s[i]=';' then break;
end;
end
else if result='<' then
begin
for i:=StartIdx+1 to length(s) do
begin
result:=result+s[i];
if s[i]='>' then break;
end;
end
else begin
for i:=StartIdx+1 to length(s) do
if s[i] in ['&','<'] then break
else result:=result+s[i];
end;
end;
// 输入：<a href="http://anjo.delphibbs.com">
// 输出：http://anjo.delphibbs.com
function GetLink(s:string):string;
var
LPos,RPos,LQuot,RQuot:integer;
begin
result:='';
// 去掉'....<'
LPos:=pos('<',s);
if LPos=0 then exit;
delete(s,1,LPos);
s:=Trim(s);
// 去掉'>....'
RPos:=pos('>',s);
if RPos=0 then exit;
delete(s,RPos,MaxInt);
if uppercase(copy(s,1,2))='A ' then
begin
LPos:=pos('HREF',uppercase(s));
if LPos=0 then exit;
LQuot:=NPos('"',s,1);
RQuot:=NPos('"',s,2);
if (LQuot<LPos) or (RQuot>RPos) then exit;
// 开头带'#'的超链接，视为无效
if s[LQuot+1]='#' then exit;
// 开头带'javascript:'的超链接，也视为无效
// 如：<div align=right><a href="javascript:window.close()"><IMG SRC="button_close.gif"></a></div>
if copy(s,LQuot+1,11)='javascript:' then exit;
result:=copy(s,LQuot+1,RQuot-LQuot-1);
end;
end;
// 把所有&xxx的转义；所有<xxx>取消；其它照样返回
function ConvertHTMLToken(const s:string;var inPre:boolean):string;
var
s0,s0_2,s0_3,s0_4:string;
begin
if s='' then
begin
result:='';
exit;
end;
if s[1]='&' then
begin
s0:=lowerCase(s);
result:='';
if s0=' ' then result:=' '
else if s0='"' then result:='"'
else if s0='>' then result:='>'
else if s0='<' then result:='<'
else if s0='·' then result:='·'
else if s0='™' then result:=' TM '
else if s0='©' then result:='(c)'
else if s0='®' then result:='(R)'
else if s0='&' then result:='&';
end
else if s[1]='<' then
begin
s0:=lowerCase(s);
s0_2:=copy(s0,1,2);
s0_3:=copy(s0,1,3);
s0_4:=copy(s0,1,4);
result:='';
// 将所有<hr>替换成为'------'
if s0='<br>' then result:=CR
else if s0_4='<pre' then // <pre 一定要在 <p 之前判断！
begin
inPre:=true;
result:=CR;
end
else if s0_2='<p' then result:=CR+CR
else if s0_3='<hr' then result:=CR+MakeStr('-',40)+CR
else if s0_3='<ol' then result:=CR
else if s0_3='<ul' then result:=CR
else if s0_3='<li' then result:='·'
else if s0_4='</li' then result:=CR
else if s0_4='</tr' then result:=CR
else if s0='</td>' then result:=#9
else if s0='<title>' then result:='《'
else if s0='</title>' then result:='》'+CR+CR
else if s0='</pre>' then inPre:=false
else if copy(s0,1,6)='<table' then result:=CR
else if (s0[2]='a') then
begin
CurrLink:=GetLink(s);
if CurrLink<>'' then result:='[';
end
else if (s0='</a>') then
if CurrLink<>'' then result:=format(' %s ]',[CurrLink]);
end
else if inPre then result:=s
else // 不在<pre>..</pre>内，则删除所有CR
result:=ReplaceStr(s,CR,'');
end;
begin
s0:=UnixToDos(value);
result:='';
InputLen:=length(s0);
InputIdx:=1;
inPre:=false;
CurrLink:='';
while InputIdx<=InputLen do
begin
NextToken:=GetNextToken(s0,InputIdx);
// 去除<style ...> -- </style>之间的内容
if lowercase(copy(NextToken,1,6))='<style' then begin
while lowercase(NextToken)<>'</style>' do begin
inc(InputIdx,length(NextToken));
NextToken:=GetNextToken(s0,InputIdx);
end;
inc(InputIdx,length(NextToken));
NextToken:=GetNextToken(s0,InputIdx);
end;
// 去除<Script ...> -- </Script>之间的内容
if lowercase(copy(NextToken,1,7))='<script' then
begin
inc(InputIdx,length(NextToken));
inQuot:=false;
i:=InputIdx-1;
while I<InputLen do
begin
inc(i);
if s0[i]='"' then
begin
inQuot:=not inQuot;
continue;
end;
if not inQuot then
// 去除<script>段里的<!-- ... -->注释段, 99.8.2
if copy(s0,i,4)='<!--' then
begin
HelpIdx:=pos('-->',copy(s0,i+4,MaxInt));
if HelpIdx>0 then
begin
inc(i,4+HelpIdx+2);
end
else begin
i:=InputLen;
break;
end;
end;
if lowercase(copy(s0,i,9))='</script>' then
begin
break;
end;
end;
InputIdx:=i;
end;
NextToken:=GetNextToken(s0,InputIdx);
inc(InputIdx,length(NextToken));
result:=result+ConvertHTMLToken(NextToken,inPre);
end;
end;
function ExtractURL(value, Delimiter : string) : string;
const
URLHeads : array[1..6] of string =
('http://', 'ftp://', 'news:', 'mailto:', 'https://', 'telnet:');
URLHeadChar : set of Char =
['h', 'f', 't', 'n', 'm'];
URLChars : set of Char =
['0'..'9', 'A'..'Z', 'a'..'z', ':', '.', '/', '\', '@','?', '_'];
//判断是否是链接地址的头
function IsURL(var index : integer): integer;
var
i : integer;
begin
result := -1;
If value[index] in URLHeadChar then
for i := low(URLHeads) to High(URLHeads) do
If copy(value, index, length(URLHeads[i])) = URLHeads[i] then
begin
result := i;
inc(index, length(URLHeads[I]));
exit;
end;
end;
var
I, P : Integer;
Head, url : string;
begin
I := 1;
while I <= Length(value) do
begin
P := IsUrl(I);
If P > -1 then
begin
head := URLHeads[p];
url := '';
for I := i To Length(value)+1 do
begin
If (value[i] in URLChars) then
begin
⌨️ 快捷键说明
复制代码
Ctrl + C
搜索代码
Ctrl + F
全屏模式
F11
切换主题
Ctrl + Shift + D
显示快捷键
?
增大字号
Ctrl + =
减小字号
Ctrl + -