DELPHI中一些处理数据的实用函数

//获得IP地址，名称
function GetIPFromHost(var HostName, IPaddr, WSAErr: string): Boolean;
type
  Name = array[0..100] of Char;
  PName = ^Name;
var
  HEnt: pHostEnt;
  HName: PName;
  WSAData: TWSAData;
  i: Integer;
begin
  Result := False;
  if WSAStartup($0101, WSAData) <> 0 then begin
    WSAErr := 'Winsock is not responding."';
    Exit;
  end;
  IPaddr := '';
  New(HName);
  if GetHostName(HName^, SizeOf(Name)) = 0 then
  begin
    HostName := StrPas(HName^);
    HEnt := GetHostByName(HName^);
    for i := 0 to HEnt^.h_length - 1 do
     IPaddr :=
      Concat(IPaddr,
      IntToStr(Ord(HEnt^.h_addr_list^[i])) + '.');
    SetLength(IPaddr, Length(IPaddr) - 1);
    Result := True;
  end
  else begin
   case WSAGetLastError of
    WSANOTINITIALISED:WSAErr:='WSANotInitialised';
    WSAENETDOWN      :WSAErr:='WSAENetDown';
    WSAEINPROGRESS   :WSAErr:='WSAEInProgress';
   end;
  end;
  Dispose(HName);
  WSACleanup;
end;
//获得工作站名称
function GetMyHostName : string;
var
  i : integer;
  Hostname : array[1..20] of Char;
  WSData : TWSAData;
//  CSet : set of #0..#255;
begin
  if WSAStartup(2,WSData) <> 0 then begin
    MessageBox(Application.Handle,Pchar('不能初始化WinSock!'),Pchar('错误'),MB_OK);
    exit;
  end;
  try
    if GetHostName(@Hostname[1],32) <> 0 then begin
      MessageBox(Application.Handle,Pchar('不能获得工作站名称!'),Pchar('错误'),MB_OK);
      exit;
    end;
  except
    MessageBox(Application.Handle,Pchar('不能获得工作站名称!'),Pchar('错误'),MB_OK);
    exit;
  end;
  for i := 1 to 20 do begin
    if hostname[i] = #0 then
      Break;
    Result := Result + hostname[i];
  end;
end;
function GetSubStr(sGroup,sSeparator : string; iNo : integer) : string;
var
  i : integer;
begin
   i := 1;
   if (MyPos(sSeparator,sGroup) = 0) or (sGroup = '') then begin
     if iNo = i then
       Result := sGroup
     else if iNo > i then
       Result := '';
     Exit;
   end;
   while MyPos(sSeparator,sGroup) > 0 do begin
     if i = iNo then begin
       Result := Copy(sGroup,1,MyPos(sSeparator,sGroup)-1);
       Exit;
     end else begin
       Delete(sGroup,1,MyPos(sSeparator,sGroup) + Length(sSeparator) - 1);
       if sSeparator = ' ' then
         sGroup := Trim(sGroup);
     end;
     Inc(i);
   end;
   if iNo = i then
     Result := sGroup
   else if iNo > i then
     Result := '';
end;
function GetSubStrCount(sGroup,sSeparator : string) : integer;
var
  i : integer;
begin
   Result := 1;
   i := 0;
   if (MyPos(sSeparator,sGroup) = 0) or (sGroup = '') then
     Exit;
   while MyPos(sSeparator,sGroup) > 0 do begin
     Inc(i);
     Delete(sGroup,1,MyPos(sSeparator,sGroup) + Length(sSeparator) - 1);
     if sSeparator = ' ' then
       sGroup := Trim(sGroup);
   end;
   Result := i + 1;
end;
function GetStrIncDec(sType : string; var sStr : string;iDist : integer;bKeep : Boolean) : Boolean;
var
  iMid : LongInt;
  iStrLen : integer;
begin
  Result := false;
  iMid := StrToInt(sStr);
  iStrLen := Length(sStr);
  
  if sType = 'I' then
    sStr := StringOfChar('0',iStrLen-Length(IntToStr(iMid + iDist)))
          + IntToStr(iMid + iDist)
  else
    sStr := StringOfChar('0',iStrLen-Length(IntToStr(iMid - iDist)))
          + IntToStr(iMid - iDist);
  if Length(sStr) > iStrLen then
    if bKeep then begin
      MessageDlg('代码递增超出级长!',mtError,[mbYes],0);
      Exit;
    end;
  Result := true;
end;
//小写金额转换大写金鹅
function NoToBigMoney(S:string):string;
var
  odxc,odxs,oszc,oscc,oscc0:string;
  oi,oi0:Integer;
  ormb:Double;
begin
  if (Length(S)<=8) and (StrToFloatDef(S,0)=0.00) then begin
    Result := '零圆整'+StringOfChar(' ',BigMoneyLength-Length('零圆整'));
    Exit;
  end;
  ormb:=StrToFloat(S)*100; //金额小写(分数）
  ormb := StrToFloat(FormatFloat('0',ormb));
  if ormb=0.00 then begin
    Result := '零圆整'+StringOfChar(' ',BigMoneyLength-Length('零圆整'));
    Exit;
  end;
  odxc :='分角圆拾佰仟万拾佰仟亿拾佰仟万拾佰仟亿';
  odxs :='零壹贰叁肆伍陆柒捌玖';
  oszc :=FloatToStr(abs(ormb));
//  i:=AnsiPos('.',s);
//  Delete(oszc,i,1); // stuf(oszc,18,1,'');                 b
  oszc:=Trim(oszc);
  oscc:='';
  oi0:=0;
  for oi:=Length(oszc) downto 1 do begin
    oscc:=Copy(odxc,oi0*2+1,2)+oscc;
    oscc:=Copy(odxs,StrToInt(Copy(oszc,oi,1))*2+1,2)+oscc;
    Inc(oi0);
  end;
  oscc0:='';
  oi :=-3;
  while oi<=Length(oscc) do begin
    Inc(oi,4);
    if Copy(oscc,oi,2)='零' then begin
      if Copy(oscc,oi+2,2)='万' then begin
        if Copy(oscc0,Length(oscc0)-3,4)<>'亿零' then begin
          if Copy(oscc0,Length(oscc0)-1,2)='零' then
            oscc0:=Copy(oscc0,1,Length(oscc0)-2)+'万'
          else oscc0:=oscc0+'万';
        end;
        Continue;
      end;
      if Copy(oscc,oi+2,2)='圆' then begin
        if Copy(oscc0,Length(oscc0)-1,2)='零' then
          oscc0:=Copy(oscc0,1,Length(oscc0)-2)+'圆'
        else oscc0:=oscc0+'圆';
        Continue;
      end;
      if Copy(oscc,oi+2,2)='亿' then begin
        if Copy(oscc0,Length(oscc0)-1,2)='零' then
          oscc0:=Copy(oscc0,1,Length(oscc0)-2)+'亿'
        else oscc0:=oscc0+'亿';
        Continue;
      end;
      if Copy(oscc0,Length(oscc0)-1,2)<>'零' then
        oscc0:=oscc0+'零';
    end else
      oscc0:=oscc0+Copy(oscc,oi,4);
  end;
  if Copy(oscc0,Length(oscc0)-3,4)='圆零' then begin
    oscc0:=Copy(oscc0,1,Length(oscc0)-2)+'整';
    Result := oscc0+StringOfChar(' ',BigMoneyLength-Length(oscc0));
    Exit;
  end;
  if Copy(oscc0,Length(oscc0)-3,4)='角零' then begin
    oscc0:=Copy(oscc0,1,Length(oscc0)-2)+'整';
    Result := oscc0+StringOfChar(' ',BigMoneyLength-Length(oscc0));
    Exit;
  end;
  if Copy(oscc0,Length(oscc0)-1,2)='零' then
    oscc0:=Copy(oscc0,1,Length(oscc0)-2)+'圆整';
    Result := oscc0+StringOfChar(' ',BigMoneyLength-Length(oscc0));
  Result := Trim(Result);
end; 
//去掉字符串中的空格
function NoEmptyChar(s_Temp : string; s_Split : Char) : string;
var
  i : integer;
  b_Continue : Boolean;
begin
  Result := '';
  b_Continue := false;
  if s_Split = ' ' then begin
    Result := s_Temp;
    Exit;
  end;
  for i := 1 to Length(s_Temp) do begin
    if s_Temp[i] <> ' ' then begin
      Result := Result + s_Temp[i];
      b_Continue := true;
    end else if b_Continue then
      Result := Result + s_Temp[i];
    if s_Temp[i] = s_Split then
      b_Continue := false;    
  end;
end; 

//数字类型千分符号化表示
function CastKSpliter(s_Numeric : string) : string;
var
  i,j : integer;
  s_Temp, s_Result : string;
begin
  s_Result := '';
  s_Numeric := Trim(s_Numeric);
  s_Temp := GetSubStr(s_Numeric,'.',1);
  j := 0;
  for i := Length(s_Temp) downto 1 do begin
    Inc(j);
    if j = 3 then begin
      j := 0;
      if (s_Temp[i-1] <> '') and (s_Temp[i-1] <> '-') then
        s_Result := ',' + s_Temp[i] + s_Result
      else
        s_Result := s_Temp[i] + s_Result;
    end else
      s_Result := s_Temp[i] + s_Result;
  end;
  s_Temp := GetSubStr(s_Numeric,'.',2);
  if s_Temp <> '' then
    Result := s_Result + '.' + s_Temp
  else
    Result := s_Result;
end;
function GetLeft(const S : string; const Len : Integer):string;
begin
  Result := Trim(S)+StringOfChar(' ',Len-Length(Trim(S)));
end;
function GetRight(const S : string; const Len : Integer):string;
begin
  Result := StringOfChar(' ',Len-Length(Trim(S))) + Trim(S);
end;
//提取网页项目比如 <td>ABC</td>
function GetHtmlItem(str_Temp : string) : string;
var
  int_StartTd,int_StartPos,int_EndPos : integer;
begin
  Result := '';
  str_Temp := LowerCase(str_Temp);
  int_StartTd := MyPos('<TD',UpperCase(str_Temp));
  Delete(str_Temp,1,int_StartTd + 1);
  int_StartPos := MyPos('>',str_Temp);
  int_EndPos := MyPos('<',str_Temp);
  if (int_StartPos > 0) and (int_EndPos > 0) then
    Result := Trim(Copy(str_Temp,int_StartPos + 1,int_EndPos - int_StartPos - 1));
  Result := StringReplace(Result,'&nbsp;','',[rfReplaceAll]);
end;
function GetHSpanItem(str_Temp : string;sl_Temp : TStringList) : Boolean;
var
  int_Temp1,int_Temp2 : integer;
  bol_Flag : Boolean;
begin
  Result := true;
  try
    sl_Temp.Clear;
    str_Temp := UpperCase(str_Temp);  //大写
//    str_Temp2 := str_Temp;
    //判断是否需要提取数据,其依据是被SPAN网页元素修饰
    int_Temp1 := MyPos('<SPAN',str_Temp);
    int_Temp2 := MyPos('</SPAN>',str_Temp);
    if (int_Temp1 = 0) and (int_Temp2 = 0) then begin
      int_Temp1 := MyPos('LEFT',str_Temp);
      int_Temp2 := MyPos('POSITION',str_Temp);
    end;
    while (int_Temp1 > 0) or (int_Temp2 > 0) do begin
      bol_Flag := false;  //数据位置的合法性
      //处理网页字符串中直接以数据开始
      int_Temp1 := MyPos('<',str_Temp);
      int_Temp2 := MyPos('>',str_Temp);
      if ((int_Temp1 < int_Temp2) or (int_Temp2 = 0))
         and (int_Temp1 = MyPos('</SPAN',str_Temp))
         and (int_Temp1 <> 1) and (int_Temp1 > 0) then begin
        sl_Temp.Add(Copy(str_Temp,1,int_Temp1-1));
        Delete(str_Temp,1,int_Temp1);
      end;
      //删除 '><'之前的资料
      int_Temp1 := MyPos('><',str_Temp);
      int_Temp2 := MyPos('>',str_Temp);
      while (int_Temp1 > 0) and (int_Temp1 = int_Temp2) do begin
        Delete(str_Temp,1,int_Temp1 + 1);
        int_Temp1 := MyPos('><',str_Temp);
        int_Temp2 := MyPos('>',str_Temp);
      end;
      //定位数据资料,正常情况数据紧跟>其后
      int_Temp1 := MyPos('>',str_Temp);
      if int_Temp1 > 0 then begin
        Delete(str_Temp,1,int_Temp1);
        bol_Flag := true;
      end;
      //数据开始
      int_Temp1 := MyPos('<',str_Temp);
      if (int_Temp1 > 0) and (int_Temp1 <> 1) then begin
        sl_Temp.Add(Copy(str_Temp,1,int_Temp1-1));
        Delete(str_Temp,1,int_Temp1);
        int_Temp1 := MyPos('/SPAN',str_Temp);
        if int_Temp1 > 0 then
          Delete(str_Temp,1,int_Temp1 + 5)
        else begin
          int_Temp1 := MyPos('</SPAN',str_Temp);
          if int_Temp1 > 0 then
            Delete(str_Temp,1,int_Temp1 + 6);
        end;
      end else if (int_Temp1 <> 1) and (Trim(str_Temp) <> '') then begin
        if bol_Flag then
          sl_Temp.Add(str_Temp);
//        showmessage(str_Temp2);
      end else
        str_Temp := '';
      int_Temp1 := MyPos('<SPAN',str_Temp);
      if int_Temp1 > 0 then
        Delete(str_Temp,1,int_Temp1 + 5);
      int_Temp2 := MyPos('</SPAN>',str_Temp);
    end;
  except
    Result := false;
    //...
  end;
end;
//真实精确定位
function MyPos(str_Separator,str_Temp : string) : integer;
var
  i : integer;
  bol_IsDBCS,bol_CnEnd : boolean;
begin
  Result := 0;
  bol_IsDBCS := false;
  bol_CnEnd := true;
  if Length(str_Separator) = 1 then
    for i := 1 to Length(str_Temp) do begin
      if bol_CnEnd and (str_Temp[i] = str_Separator) then begin
        Result := i;
        Break;
      end;
      if Ord(str_Temp[i]) >= 127 then begin
        if (not bol_IsDBCS) and bol_CnEnd then
          bol_CnEnd := false
        else
          bol_CnEnd := not bol_CnEnd;
        bol_IsDBCS := true;
      end else begin
        if (((Ord(str_Temp[i]) < 127) or (Ord(str_Temp[i-1]) >= 127))) and not bol_CnEnd then
          bol_IsDBCS := true
        else
          bol_IsDBCS := false;
        bol_CnEnd := true;
      end;
    end
  else
    Result := Pos(str_Separator,str_Temp);
end;
function GetAdd(str_Temp : string;str_Add : string) : string;
var
  i,j,k : integer;
  str_Jia : string;
begin
  Result := str_Temp;
  j := Length(str_Add);
  for i := Length(str_Temp) downto 1 do begin
    if j > 0 then begin
      str_Jia := IntToStr(StrToInt(str_Temp[i]) + StrToInt(str_Add[j]));
      str_Temp[i] := str_Jia[Length(str_Jia)];
      k := i - 1;
      while Length(str_Jia) > 1 do begin
        str_Jia := IntToStr(StrToInt(str_Jia[1]) + StrToInt(str_Temp[k]));
        str_Temp[k] := str_Jia[Length(str_Jia)];
        if (k = 0) and (Length(str_Jia) > 1) then begin
          str_Temp := str_Jia[1] + str_Temp;
          Break;
        end;
        k := k - 1;
      end;
    end else
      Break;
    j := j - 1;
  end;
  Result := str_Temp;
end;
function IIf(bol_Temp : Boolean;str_Yes,str_No : string) : string;
begin
  if bol_Temp then
    Result := str_Yes
  else
    Result := str_No;
end;
//end
//----------------------------procedures--------------------------------------//
//begin
procedure StepReplace(var s:string;const SourceChar:Char;const RChar:Char);
var
  i : integer;
  s_Temp : string;
begin
  s_Temp := '';
  for i := 1 to Length(s) do
    if s[i] = SourceChar then
      s_Temp := s_Temp + RChar
    else
      s_Temp := s_Temp + s[i];
      
  s := s_Temp;
end;
procedure Replace(var s: string; const SourceChar, RChar: pchar);
var
  ta,i,j:integer;
  m,n,pn,sn:integer;
  SLen,SCLen,RCLen:integer;//SLen表示原串的长度，SCLen表示模式传的长度，RCLen表示替换串的长度
  IsSame:integer;
  newp:array of char;//用来保存替换后的字符数组
begin
  SLen:=strlen(pchar(s));SCLen:=strlen(SourceChar);RCLen:=strlen(RChar);
{  for j := 0 to SLen-1 do begin
    if ss then
      showmessage(IntToStr(Ord(s[j])) + '---' + s[j]);
    if s[j] = SourceChar  then
      showmessage('Find');
  end;  }
  j:=MyPos(string(SourceChar),s);
  s:=s+chr(0);ta:=0;i:=j;
  while s[i]<>chr(0) do   //这个循环用ta统计模式串在原串中出现的次数
  begin
    n:=0;IsSame:=1;
    for m:=i to i+SCLen-1 do
    begin
     if m>SLen then begin IsSame:=0;break; end;
     if s[m]<>sourceChar[n] then begin IsSame:=0;break; end;
     n:=n+1;
    end;
    if IsSame=1 then begin ta:=ta+1;i:=m; end else i:=i+1;
  end;
  if j>0 then
  begin
   pn:=0;sn:=1;
   setlength(newp,SLen-ta*SCLen+ta*RCLen+1);//分配newp的长度，+1表示后面还有一个#0结束符
   while s[sn]<>chr(0) do //主要循环，开始替换
   begin
    n:=0;IsSame:=1;
    for m:=sn to sn+SCLen-1 do //比较子串是否和模式串相同
    begin
     if m>SLen then begin IsSame:=0;break; end;
     if s[m]<>sourceChar[n] then begin IsSame:=0;break; end;
     n:=n+1;
    end;
    if IsSame=1 then//相同
    begin
     for m:=0 to RCLen-1 do
     begin
      newp[pn]:=RChar[m];pn:=pn+1;
     end;
     sn:=sn+SCLen;
    end
    else
    begin //不同
     newp[pn]:=s[sn];
     pn:=pn+1;sn:=sn+1;
    end;
   end;
   newp[pn] := chr(0);
   s:=string(newp); //重置s，替换完成！
end;
s := Copy(s,1,Length(s)-1);
end;
procedure OpenForm(s_Caption : string;s_FormName : string;s_ClassName : string);
var
  i : Integer;
  ChildForm : TForm;
  ChildClass : TFormClass;
begin
  try
    Screen.Cursor := crSqlWait;
    try
      ChildClass := TFormClass(GetClass(s_ClassName));
      for i:=0 to Screen.FormCount-1 do
        if (Screen.Forms[i].ClassType = ChildClass) and (Screen.Forms[i].Name = s_FormName) then begin
          ChildForm := Screen.Forms[i];
          if ChildForm.WindowState=wsMinimized then
            ShowWindow(ChildForm.Handle,SW_SHOWNORMAL)
          else
            ShowWindow(ChildForm.Handle,SW_SHOWNA);
          if(not ChildForm.Visible) then
            ChildForm.Visible:=true;
          ChildForm.BringToFront;
          ChildForm.SetFocus;
          Exit;
        end;
      ChildForm := ChildClass.Create(Application);
      if s_Caption <> '' then
        ChildForm.Caption := s_Caption;
      ChildForm.Name := s_FormName;
      ChildForm.Show;
      ChildForm.BringToFront;
    except
      on E : Exception do begin
        MessageDlg('错误:' + E.Message,mtError,[mbYes],0);
        Exit;
      end;
    end;
  finally
    Screen.Cursor := crDefault;
  end;
end;
//分割带有特定分隔符字符串的每个分隔项目排列成字符列表
//比如:SplitStrBySeparator('A|B|C|D|E','|',MyDataList),那么MyDataList[0] = 'A'
procedure SplitStrBySeparator(DataStr,Separator:string;DataLst:TStrings);
var
  SepPos,i,j:Integer;
begin
  if (Separator<>Chr(VK_TAB)) and (Length(Trim(Separator))=0) then begin
    Application.MessageBox('无效分隔符','提示');
    Exit;
  end;
  i:=0;
  while True do begin
    if Length(DataStr)=0 then Break;
    SepPos:=MyPos(Separator,DataStr);
    if SepPos<>0 then begin
      if DataLst.Count>i then DataLst.Strings[i] := Copy(DataStr,1,SepPos-1)
      else DataLst.Add(Copy(DataStr,1,SepPos-1));
      DataStr := Copy(DataStr,SepPos+Length(Separator),Length(DataStr)-SepPos-Length(Separator)+1);
    end else begin
      if DataLst.Count>i then DataLst.Strings[i] := DataStr
      else DataLst.Add(DataStr);
      Inc(i);
      Break;
    end;
    Inc(i);
  end;
  for j:= DataLst.Count-1 downto i do DataLst.Delete(j);
end;
procedure StepSplitStrBySeparator(var s:string;const SplitChar:Char;DataLst:TStrings);
var
  i : integer;
  s_Temp : string;
begin
  DataLst.Clear;
  
  for i := 1 to Length(s) do begin
    if s[i] <> SplitChar then
      s_Temp := s_Temp + s[i]
    else begin
      DataLst.Add(Trim(s_Temp));
      s_Temp := '';
    end;
  end;
end;
procedure StrAdd(sl_Temp : TStrings;str_Head : string;var str_Result : string;str_Temp : string;var posNo : integer;maxNo : integer);
begin
  if posNo > maxNo then begin
    sl_Temp.Add(str_Result);
    if str_Head <> '' then
      str_Result := str_Head + '|' + str_Temp
    else
      str_Result := str_Temp;
    posNo := 1;
  end else
    str_Result := str_Result + '|' + str_Temp;
end;
end