skypublic.pas

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

var
  I: Integer;
begin
  Result := doMDY;
  I := 1;
  while I <= Length(DateFormat) do
  begin
    case Chr(Ord(DateFormat[I]) 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[I] = '' then Break;
    if AnsiStrPos(PChar(EraNames[I]), PChar(Name)) <> nil then
    begin
      Result := EraYearOffsets[I];
      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[i]+#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[i] in ['0'..'9'] then
  begin
    NumPart:=Str[i]+NumPart;
    Dec(i);
    while Str[i] in ['1'..'9'] do
    begin
      NumPart:=Str[i]+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;

{FloatTo%百分比}
function FloatToRate(Num:Double;Pos:Word):string;
var
  TempNum:Double;
  Str:string;
begin
  TempNum:=100*Num;
  Str:=FloatToStrF(TempNum,ffGeneral,Pos,15);
  Str:=Str+'%';
  Result:=Str;
end;

function Power(X,Y:Extended):Extended;
begin
  Result:=Exp(Y*LN(X));
end;

{关闭计算机}
function WinExit (iFlags: integer) : Boolean;
{0:注销
 1:关闭计算机
 2:重新启动计算机
 4:强制注销(不保存状态)
 8:关闭电源
 16:注销}

  function SetPrivilege (sPrivilegeName: string; bEnabled: Boolean) : Boolean;
  var
    TPPrev,TP: TTokenPrivileges;
    Token    : THandle;
    dwRetLen : DWORD;
  begin
    result := False;
    OpenProcessToken(GetCurrentProcess, TOKEN_ADJUST_PRIVILEGES or TOKEN_QUERY, Token);
    TP.PrivilegeCount := 1;
    if LookupPrivilegeValue (nil, PChar (sPrivilegeName), TP.Privileges[0].LUID) then
    begin
      if bEnabled then TP.Privileges[0].Attributes := SE_PRIVILEGE_ENABLED
      else TP.Privileges[0].Attributes := 0;
      dwRetLen := 0;
      result := AdjustTokenPrivileges(Token, False, TP, SizeOf (TPPrev), TPPrev,dwRetLen);
    end;
    CloseHandle(Token);
  end;

begin
  Result:=False;
  if SetPrivilege ('SeShutdownPrivilege', true) then
  begin
    if  ExitWindowsEx(iFlags, 0) then result:=True;
    SetPrivilege ('SeShutdownPrivilege', False);
  end
end;

{防止开启多个应用程序}
procedure PreventMany(Name:string);
begin
  CreateMutex(Nil,false,PChar(Name));
  if GetLastError=Error_ALREADY_EXISTS then
  begin
    SendMessage(HWND_BROADCAST,RegisterWindowMessage(PChar(Name)),0,0);
    Halt(0);
  end;
end;

{TStrings，在Combobox中添加或者删除一个字符串}
procedure StringsOperation(ComboBox:TComboBox;IsAdd:Boolean;No:string='');
var
  I:Integer;
begin
  if IsAdd then
  begin
    ComboBox.Items.Add(No);
    ComboBox.ItemIndex:=ComboBox.Items.IndexOf(No);
  end
  else begin
    I:=ComboBox.ItemIndex;
    if I>-1 then
    begin
      ComboBox.Items.Delete(i);
      if ComboBox.Items.Count>0 then
      begin
        if i=ComboBox.Items.Count then
          i:=i-1;
        ComboBox.ItemIndex:=i;
      end
    end;
  end;
end;

function FloatToNewFloat(AValue:Double):Double;
var
  IntPart,PointPart:Integer;
begin
  IntPart:=Trunc(AValue);
  PointPart:=Round(10000*(AValue-IntPart));
  if (PointPart>=1)and(PointPart<99) then
  begin
    AValue:=RoundTo(AValue,-4);
  end
  else if (PointPart>=100)and(PointPart<999) then
  begin
    AValue:=RoundTo(AValue,-3);
  end
  else if (PointPart>=1000)and(PointPart<9999) then
  begin
    AValue:=RoundTo(AValue,-2);
  end;
  Result:=AValue;
end;

function FloatToNewFloatN(AValue:Double;N:Word=4):Double;
var
  IntPart,PointPart:Integer;
  NN:Word;
  K:Integer;

  function EE(T:Word):Word;
  var
    PP:Word;
    KK:Word;
  begin
    PP:=1;
    KK:=0;
    Repeat
      PP:=PP*10;
      Inc(KK);
    until KK>=T;
    Result:=PP;
  end;
begin
  NN:=EE(N);
  IntPart:=Trunc(AValue);
  PointPart:=Round(NN*(AValue-IntPart));
  K:=N;
  while K>2 do
  begin
    if (PointPart>NN+1-EE(K))and(PointPart<NN-1-EE(K-1)) then
    begin
      AValue:=RoundTo(AValue,-K);
      Break;
    end
    else K:=K-1;
  end;
  Result:=AValue;
end;

function Order(N: Word): Extended;
begin
  if N>1754 then
    raise Exception.Create('数值太大');
  if N>1 then
    Result:=N * Order(N-1)
  else
    Result:=1;
end;

function GetFloatPointNum(Fl:Double):Integer;
var
  S:string;
begin
  S:=FloatToStr(Fl+1);
  Result:=Length(S)-Pos('.',S);
end;

procedure FontRecordToFont(FontRecord:TFontRecord;Font:TFont);
begin
  with FontRecord do
  begin
    Font.Charset:=CharSet;
    Font.Color:=Color;
    Font.Name:=Name;
    Font.Size:=Size;
    case Pitch of
      0:Font.Pitch:=fpDefault;
      1:Font.Pitch:=fpVariable;
      2:Font.Pitch:=fpFixed;
    end;
    Font.Style:=IntToFontStyles(Style);
  end;
end;

function FontToFontRecord(Font:TFont):TFontRecord;
begin
  with Font do
  begin
    Result.CharSet:=Charset;
    Result.Color:=Color;
    Result.Height:=Height;
    Result.Name:=Name;
    case Pitch of
      fpDefault:Result.Pitch:=0;
      fpVariable:Result.Pitch:=1;
      fpFixed:Result.Pitch:=2;
    end;
    Result.Size:=Size;
    Result.PixelsPerInch:=PixelsPerInch;
    Result.Style:=FontStylesToInt(Style);
  end;
end;

function FontStylesToInt(FontStyles:TFontStyles):Byte;
var
  T:Integer;
begin
  T:=0;
  if fsBold in FontStyles then
    T:=T+8;
  if fsItalic in FontStyles then
    T:=T+4;
  if fsUnderline in FontStyles then
    T:=T+2;
  if fsStrikeOut in FontStyles then
    T:=T+1;
  Result:=T;
end;

function IntToFontStyles(FontInteger:Byte):TFontStyles;
var
  FontT:TFontStyles;
begin
  if (FontInteger>15) then
  begin
    Result:=[];
    Exit;
  end;
  FontT:=[];
  if FontInteger>=8 then
  begin
    FontT:=FontT+[fsBold];
    FontInteger:=FontInteger-8;
  end;
  if FontInteger>=4 then
  begin
    FontT:=FontT+[fsItalic];
    FontInteger:=FontInteger-4;
  end;
  if FontInteger>=2 then
  begin
    FontT:=FontT+[fsUnderline];
    FontInteger:=FontInteger-2;
  end;
  if FontInteger>=1 then
    FontT:=FontT+[fsStrikeOut];
  Result:=FontT;
end;

end.