skypublic.pas

delphi常使用函数,你了解她的常识用函数吗? 请在这里查看你需要的函数类,提供的比较全面

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[i]);              // fill set with array items
    if not CaseSensitive then begin      // if not case sensitive, then also
      if A[i] in ['A'..'Z'] then
        Include(CharSet, Chr(Ord(A[i]) + 32))  // include lower cased or
      else if A[i] in ['a'..'z'] then
        Include(CharSet, Chr(Ord(A[i]) - 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[i] in CharSet) then begin  // add good chars to Result
      Result[count + 1] := S[i];
      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:=TrimEnterLeft(S);
  S:=TrimEnterRight(S);
  Result:=S;
end;

{  *** PChar string functions ***  }
procedure StrGetCurLine(StartPos, CurPos: PChar; TotalLen: integer;
                        var LineStart: PChar; var LineLen: integer);
var
  FloatPos, EndPos: PChar;
begin
  FloatPos := CurPos;
  LineStart := nil;
  repeat
    if FloatPos^ = LF then
    begin
      dec(FloatPos);
      if FloatPos^ = CR then
      begin
        inc(FloatPos, 2);
        LineStart := FloatPos;
      end;
    end
    else
      dec(FloatPos);
  until (FloatPos <= StartPos) or (LineStart <> nil);
  if LineStart = nil then LineStart := StartPos;
  FloatPos := CurPos;
  EndPos := StartPos;
  inc(EndPos, TotalLen - 1);
  LineLen := 0;
  repeat
    if FloatPos^ = CR then
    begin
      inc(FloatPos);
      if FloatPos^ = LF then
      begin
        dec(FloatPos, 2);
        LineLen := FloatPos - LineStart + 1;
      end;
    end
    else
      inc(FloatPos);
  until (FloatPos >= EndPos) or (LineLen <> 0);
  if LineLen = 0 then
    LineLen := integer(EndPos) - integer(LineStart)+1;
end;

function StrIPos(Str1, Str2: PChar): PChar;
{ Warning: this function is slow for very long strings. }
begin
  Result := Str1;
  dec(Result);
  repeat
    inc(Result);
    Result := StrIScan(Result, Str2^);
  until (Result = nil) or (StrLIComp(Result, Str2, StrLen(Str2)) = 0);
end;

function StrIScan(Str: PChar; Chr: Char): PChar;
asm
  push  edi                 // save edi
  push  eax                 // save eax (Str addr)
  mov   edi, Str            // store Str in edi
  mov   ecx, $FFFFFFFF      // max counter
  xor   al, al              // null char in al
  repne scasb               // search for null
  not   ecx                 // ecx = length of Str
  pop   edi                 // restore Str in edi
  mov   al, Chr             // put Chr in al
  cmp   al, 'a'             // if al is lowercase...
  jb    @@1
  cmp   al, 'z'
  ja    @@1
  sub   al, $20             // force al to uppercase
@@1:
  mov   ah, byte ptr [EDI]  // put char from Str in ah
  cmp   ah, 'a'             // if al is lowercase...
  jb    @@2
  cmp   ah, 'z'
  ja    @@2
  sub   ah, $20             // force al to uppercase
@@2:
  inc   edi                 // inc to next char in string
  cmp   al, ah              // are chars the same?
  je    @@3                 // jump if yes
  loop  @@1                 // loop if no
  mov   eax, 0              // if char is not in string...
  jne   @@4                 // go to end of proc
@@3:                        // if char is in string...
  mov   eax, edi            // move char position into eax
  dec   eax                 // go back one character because of inc edi
@@4:
  pop   edi                 // restore edi
end;

function StrLastPos(Str1, Str2: PChar): PChar;
var
  Found: Boolean;
begin
  if (Str1 <> nil) and (Str2 <> nil) and (StrLen(Str1) >= StrLen(Str2)) then
  begin
    Found := False;
    Result := Str1;
    inc(Result, StrLen(Str1) - StrLen(Str2));
    repeat
      if StrPos(Result, Str2) <> nil then
        Found := True
      else
        dec(Result);
    until (Result <= Str1) or Found;
    if not Found then Result := nil;
  end
  else
    Result := nil;
end;

procedure StrReverse(P: PChar);
var
  E: PChar;
  c: char;
begin
  if StrLen(P) > 1 then begin
    E := P;
    inc(E, StrLen(P) - 1);          // E -> last char in P
    repeat
      c := P^;                      // store beginning char in temp
      P^ := E^;                     // store end char in beginning
      E^ := c;                      // store temp char in end
      inc(P);                       // increment beginning
      dec(E);                       // decrement end
    until abs(Integer(P) - Integer(E)) <= 1;
  end;
end;

{返回中文大写数字}
function GetChinaNum(Num:TNumChar;ChinaNumFormat:TChinaNumFormat=cnfBig):string;
begin
  case ChinaNumFormat of
    cnfArab:begin
      case Num of
        '0':Result:='0';
        '1':Result:='1';
        '2':Result:='2';
        '3':Result:='3';
        '4':Result:='4';
        '5':Result:='5';
        '6':Result:='6';
        '7':Result:='7';
        '8':Result:='8';
        '9':Result:='9';
      end;
    end;
    cnfBig:begin
      case Num of
        '0':Result:='零';
        '1':Result:='壹';
        '2':Result:='贰';
        '3':Result:='叁';
        '4':Result:='肆';
        '5':Result:='伍';
        '6':Result:='陆';
        '7':Result:='柒';
        '8':Result:='捌';
        '9':Result:='玖';
      end;
    end;
    cnfSmall:begin
      case Num of
        '0':Result:='零';
        '1':Result:='一';
        '2':Result:='二';
        '3':Result:='三';
        '4':Result:='四';
        '5':Result:='五';
        '6':Result:='六';
        '7':Result:='七';
        '8':Result:='八';
        '9':Result:='九';
      end;
    end;
  end;
end;

{将数字变成中文大写}
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[i];
  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;