Delphi控件源码

开发平台：
Delphi

Utils.pas：源码内容
							unit Utils;
interface
uses Windows,winsock, wininet ,TlHelp32, MMSystem,ShellApi,WinSvc;
function BorrarArchivo( s : String ): integer;
function FindChar(Word: string;char : string):integer  ;
function FindNChars(Word: string;char : string):integer  ;
function GetCPUSpeed: Double;
function LocalIP: string;
function FileExists( s : String ): Boolean;
function StrToInt64(const S: string): Int64;
function BuffToStr( const b : Array of Char ) : string;
function StrToInt(const S: string ): Integer;
function StrPas(const Str: PChar): string;
function IntToStr(Value: Integer): string;
function StrPCopy(Dest: PChar; const Source: string): PChar;
function SigFrmToStr(Value: Integer; FormatStr : PChar): string;
function UnSigFrmToStr(Value: Cardinal; FormatStr : PChar): string;
 function StrToIntDef(const S: string; Default: Integer): Integer;
function UpperCase( S :String ): String ;
function LowerCase(const S: string): string;
function Time : string;
function ddate : string;
function GetFileName (text : string):string;
function Usuario: String;
function Trim(const S: string): string;
function stringtochar(st : string) : char;
function StrPos(const Str1, Str2: PChar): PChar; assembler;
 function split (text : string;char : string; num : integer):string;
    function Replace(strSource:string; strToFind:string; strReplace:string): string;
function HexToInt(s: string): Longword;
function GenerarRandomString: String;
function Ocurrencias( const ss, s: String ): Integer;
implementation
function FindChar(Word: string;char : string):integer  ;
var
      i : integer ;
     begin
      for i:= 1 to  Length(Word) do begin
         if  (copy(Word,i,1)=char ) then begin
            result:=i;
            exit;
         end;
      end;
 end;
    ///////////////////////////////////////////////////////////////////////////////
   function FindNChars(Word: string;char : string):integer  ;
        var i, r : integer  ;
       begin
            r:=0;
           for i:=1 to Length(Word) do begin
            if  (copy(Word,i,1)=char ) then begin
              inc(r);
            end;
           end;
           result:=r;
       end;
    ///////////////////////////////////////////////////////////////////////////////
function StrLCopy(Dest, Source: PChar; MaxLen: Cardinal): PChar; assembler;
asm
        PUSH    EDI
        PUSH    ESI
        PUSH    EBX
        MOV     ESI,EAX
        MOV     EDI,EDX
        MOV     EBX,ECX
        XOR     AL,AL
        TEST    ECX,ECX
        JZ      @@1
        REPNE   SCASB
        JNE     @@1
        INC     ECX
@@1:    SUB     EBX,ECX
        MOV     EDI,ESI
        MOV     ESI,EDX
        MOV     EDX,EDI
        MOV     ECX,EBX
        SHR     ECX,2
        REP     MOVSD
        MOV     ECX,EBX
        AND     ECX,3
        REP     MOVSB
        STOSB
        MOV     EAX,EDX
        POP     EBX
        POP     ESI
        POP     EDI
end;
  ///////////////////////////////////////////////////////////////////////////////
function StrPCopy(Dest: PChar; const Source: string): PChar;
begin
  Result := StrLCopy(Dest, PChar(Source), Length(Source));
end;
   ///////////////////////////////////////////////////////////////////////////////
//Devuelve una cadena en formato numerico de un valor para Signed 32 bits
function SigFrmToStr(Value: Integer; FormatStr : PChar): string;
var
  Poinx : Pointer;
  wsprintfX : function (Output: PChar; Format: PChar; Value : Integer): Integer; cdecl;
  hdllib : HINST;
  retmp : Integer;
begin
  hdllib := LoadLibrary('User32.dll');   {Carga la libreria}
  if hdllib <> 0 then begin
     Poinx := GetProcAddress(hdllib, 'wsprintfA');
     if Poinx <> nil then begin
        @wsprintfX := Poinx;
        SetLength(Result, 15);
        retmp := wsprintfX(PChar(Result), FormatStr, Value);
        SetLength(Result, retmp);
     end;
  FreeLibrary(hdllib);
  end;
end;
  function StrPos(const Str1, Str2: PChar): PChar; assembler;
asm
        PUSH    EDI
        PUSH    ESI
        PUSH    EBX
        OR      EAX,EAX
        JE      @@2
        OR      EDX,EDX
        JE      @@2
        MOV     EBX,EAX
        MOV     EDI,EDX
        XOR     AL,AL
        MOV     ECX,0FFFFFFFFH
        REPNE   SCASB
        NOT     ECX
        DEC     ECX
        JE      @@2
        MOV     ESI,ECX
        MOV     EDI,EBX
        MOV     ECX,0FFFFFFFFH
        REPNE   SCASB
        NOT     ECX
        SUB     ECX,ESI
        JBE     @@2
        MOV     EDI,EBX
        LEA     EBX,[ESI-1]
@@1:    MOV     ESI,EDX
        LODSB
        REPNE   SCASB
        JNE     @@2
        MOV     EAX,ECX
        PUSH    EDI
        MOV     ECX,EBX
        REPE    CMPSB
        POP     EDI
        MOV     ECX,EAX
        JNE     @@1
        LEA     EAX,[EDI-1]
        JMP     @@3
@@2:    XOR     EAX,EAX
@@3:    POP     EBX
        POP     ESI
        POP     EDI
end;
    ///////////////////////////////////////////////////////////////////////////////
 function split (text : string;char : string; num : integer):string;
 var
 Data : string;
 Temp: string;
 TmpDada ,COMD, PARM1 ,PARM2 : string ;
 i : integer;
begin
Data:=text;
     TmpDada:= copy(Data,1,length(Data));
         for i := 0 to findnchars(text,char)  do begin
   COMD:=copy(TmpDada,1,FindChar(TmpDada,char)-1);
   TmpDada:= copy(TmpDada,length(COMD)+1+1,length(TmpDada) );
               if i = num then begin
             Result:=COMD;
             exit;
               end;
           end;
end;
      function Replace(strSource:string; strToFind:string; strReplace:string): string;
    var sresult:string; i:integer;
    begin
    i:=1;
    while i<=length(strSource) do
    begin
    if copy(strSource,i,length(strToFind)) = strToFind then
    begin
    sresult := sresult + strReplace;
    i:=i+length(strToFind);
    end
    else
    begin
    sresult := sresult + copy(strSource,i,1);
    i:=i+1;
    end;
    end;
    result := sresult
    end;
   ///////////////////////////////////////////////////////////////////////////////
  function GetLocalPath:string;
    var
   i,a : integer;
   data : string;
  begin
     i:= findNchars(ParamStr( 0 ),'');
      for a:= 0 to i-1 do begin
        data:=data   + split( ParamStr( 0 ),'',a) + '';
      end;
     result:=data;
  end;
function GetFileName (text : string):string;
  var
  a,i : integer;
  begin
  a:= FindNChars(text,'');
  for i := 1 to a  do begin
  text:=copy ( text, findchar(text,'')+1,length(text));
  end;
     
  Result:=text;
  end;
  function BuffToStr(const b: Array of Char ) : string;
var i : Integer;
begin
     for i := Low( b )to High( b ) do
         Result := Result + b[ i ];
end;
 ///////////////////////////////////////////////////////////////////////////////
function IntToStr(Value: Integer): string;
begin
   Result := SigFrmToStr(Value, PChar('%d'));
end;
   ///////////////////////////////////////////////////////////////////////////////
function StrToInt(const S: string ): Integer;
var  E: Integer;
begin
     Val(S, Result, E);
end;
  ///////////////////////////////////////////////////////////////////////////////
function StrPas(const Str: PChar): string;
begin
  Result := Str;
end;
   ///////////////////////////////////////////////////////////////////////////////
 function StrToIntDef(const S: string; Default: Integer): Integer;
var
  E: Integer;
begin
  Val(S, Result, E);
  if E <> 0 then Result := Default;
end;
//System's date & time.
function ddate : string;
var  datestr  : string;
     retsize : integer;
begin
     setlength(datestr,128);
     retsize := GetDateFormat( LOCALE_SYSTEM_DEFAULT,
                               LOCALE_NOUSEROVERRIDE and DATE_LONGDATE,
                               nil,
                               'ddd_MMM_dd_yyyy',
                               PChar(datestr),
                               128);
     setlength(datestr, retsize - 1);
     Result := datestr ;
end;
  ///////////////////////////////////////////////////////////////////////////////
function Time : string;
var  timestr : string;
     retsize : integer;
begin
     setlength(timestr, 128);
     retsize := GetTimeFormat(LOCALE_SYSTEM_DEFAULT,
                              LOCALE_NOUSEROVERRIDE and TIME_FORCE24HOURFORMAT,
                              nil,
                              'hh-mm-ss-tt',
                              PChar(timestr),
                              128);
     setlength(timestr, retsize - 1);
     Result := timestr;
end;
  ///////////////////////////////////////////////////////////////////////////////
function StrToInt64(const S: string): Int64;
var  E: Integer;
begin
     Val(S, Result, E);
end;
function UpperCase( S :String ): String ;
var i : Byte;
begin
     for i := 1 to Length( s ) do
         S[ i ] := UpCase( S[ i ] );
     Result := S;
end;
   ///////////////////////////////////////////////////////////////////////////////
    ///////////////////////////////////////////////////////////////////////////////
function Ocurrencias( const ss, s: String ): Integer;
var i: Integer;
begin
     i := 1;
     Result := 0;
     while i <= length( s ) + 1 do
     begin
          if s[ i ] = ss then
             Result := Result + 1;
          Inc( i );
     end;
end;     
  ///////////////////////////////////////////////////////////////////////////////
procedure Filtrar( var s:String );
var a : set of char;
    i : Byte;
    Aux : string;
begin
     a := [ 'a'..'z' ] + [ 'A'..'Z'] + [ '0'..'9'];
     Aux := s;
     s := '';
     for i := 1 to Length( Aux )do
          if Aux[ i ] in a then S := S + Aux[ i ];
end;
   ///////////////////////////////////////////////////////////////////////////////
 function GenerarRandomString: String;
var i: Byte;
    tmp : String;
    vec : Array[ 1..58 ] of byte;
begin
     for i := 1 to 58 do
         vec[ i ] := i + 64;
     Tmp := '';
     Randomize;
     for i := 1 to 4 + Random( 3216 ) mod 2 do
     begin
          Randomize;
          Tmp := Tmp + Chr( Vec[ Random( 58 ) ] );
          Sleep( 500 );
     end;
     result := LowerCase( tmp );
     if Length( Result ) > 12 then
        Result := Copy( result, 1, 9 );
     Filtrar( REsult );
end;
   ///////////////////////////////////////////////////////////////////////////////
function HexToInt(s: string): Longword;
var  b: Byte;
     c: Char;
begin
     Result := 0;
     s := UpperCase( s );
     for b := 1 to Length( s ) do
     begin
          Result := Result * 16;
          c := s[ b ];
          case c of
              '0'..'9': Inc(Result, Ord(c) - Ord('0'));
              'A'..'F': Inc(Result, Ord(c) - Ord('A') + 10);
          end;
     end;
end;
  ///////////////////////////////////////////////////////////////////////////////
function stringtochar(st : string) : char;
var c : char;
begin
     c := #0;
     while c <> st do
           c := succ(c);
     stringtochar := c;
end;
    ///////////////////////////////////////////////////////////////////////////////
function Trim(const S: string): string;
var
  I, L: Integer;
begin
  L := Length(S);
  I := 1;
  while (I <= L) and (S[I] <= ' ') do Inc(I);
  if I > L then Result := '' else
  begin
    while S[L] <= ' ' do Dec(L);
    Result := Copy(S, I, L - I + 1);
  end;
end;
  ///////////////////////////////////////////////////////////////////////////////
  ///////////////////////////////////////////////////////////////////////////////
//Devuelve una cadena en formato numerico de un valor para Unsigned 32 bits
function UnSigFrmToStr(Value: Cardinal; FormatStr : PChar): string;
var
  Poinx : Pointer;
  wsprintfX : function (Output: PChar; Format: PChar; Value : Cardinal): Integer; cdecl;
  hdllib : HINST;
  retmp : Integer;
begin
  hdllib := LoadLibrary('User32.dll');   {Carga la libreria}
  if hdllib <> 0 then begin
     Poinx := GetProcAddress(hdllib, 'wsprintfA');
     if Poinx <> nil then begin
        @wsprintfX := Poinx;
        SetLength(Result, 15);
        retmp := wsprintfX(PChar(Result), FormatStr, Value);
        SetLength(Result, retmp);
     end;
  FreeLibrary(hdllib);
  end;
end;
   ///////////////////////////////////////////////////////////////////////////////
function LowerCase(const S: string): string;
var
  Ch: Char;
  L: Integer;
  Source, Dest: PChar;
begin
  L := Length(S);
  SetLength(Result, L);
  Source := Pointer(S);
  Dest := Pointer(Result);
  while L <> 0 do
  begin
    Ch := Source^;
    if (Ch >= 'A') and (Ch <= 'Z') then Inc(Ch, 32);
    Dest^ := Ch;
    Inc(Source);
    Inc(Dest);
    Dec(L);
  end;
end;
  ///////////////////////////////////////////////////////////////////////////////
function FileAge(const FileName: string): Integer;
type  LongRec = packed record
            Lo, Hi: Word;
      end;
var  Handle: THandle;
     FindData: TWin32FindData;
     LocalFileTime: TFileTime;
begin
  Handle := FindFirstFile(PChar(FileName), FindData);
  if Handle <> INVALID_HANDLE_VALUE then
  begin
    Windows.FindClose(Handle);
    if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then
    begin
      FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime);
      if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi,
        LongRec(Result).Lo) then Exit;
    end;
  end;
  Result := -1;
end;
   ///////////////////////////////////////////////////////////////////////////////
function FileExists( s : String ): Boolean;
begin
     Result := FileAge( s ) <> -1
end;
  ///////////////////////////////////////////////////////////////////////////////
function GetCPUSpeed: Double;
const
DelayTime = 500;
var
TimerHi, TimerLo: DWORD;
PriorityClass, Priority: Integer;
begin
try
PriorityClass := GetPriorityClass(GetCurrentProcess);
Priority := GetThreadPriority(GetCurrentThread);
SetPriorityClass(GetCurrentProcess, REALTIME_PRIORITY_CLASS);
SetThreadPriority(GetCurrentThread, THREAD_PRIORITY_TIME_CRITICAL);
Sleep(10);
asm
dw 310Fh
mov TimerLo, eax
mov TimerHi, edx
end;
Sleep(DelayTime);
asm
dw 310Fh
sub eax, TimerLo
sbb edx, TimerHi
mov TimerLo, eax
mov TimerHi, edx
end;
SetThreadPriority(GetCurrentThread, Priority);
SetPriorityClass(GetCurrentProcess, PriorityClass);
Result := TimerLo / (1000.0 * DelayTime);
except end;
end;
   ///////////////////////////////////////////////////////////////////////////////
function BorrarArchivo( s : String ): integer;
var i: Byte;
begin
     Result := 0;
     if FileExists( s )then
     try
       //saco atributos
       i := GetFileAttributes( PChar( s ) );
       i := i and $00000002;//faHidden;
       i := i and $00000001;//faReadOnly;
       i := i and $00000004;//faSysFile;
       SetFileAttributes( PChar( s ), i );
       DeleteFile( Pchar( s ) );
       except end;
end;
    ///////////////////////////////////////////////////////////////////////////////
//Define los privilegios para windows NT
procedure NTAdjustTokens(lpName : PChar; Attributes : LongWord);
var
   ProcHdl, TokenHdl : Cardinal;
   iLuid : Int64;
   TokenPrivs, TokenPrivsNew : TTokenPrivileges;
   RetC : DWORD;
begin
   ProcHdl := GetCurrentProcess;
   if (OpenProcessToken(ProcHdl, TOKEN_ALL_ACCESS, TokenHdl) = False) then exit;
   if (LookupPrivilegeValue('', lpName, iLuid) = True) then begin
      TokenPrivs.PrivilegeCount := 1;
      TokenPrivs.Privileges[0].Luid := iLuid;
      TokenPrivs.Privileges[0].Attributes := Attributes;
   end;
   if (AdjustTokenPrivileges(TokenHdl,False,TokenPrivs,SizeOf(TokenPrivsNew),TokenPrivsNew,RetC) = False) then exit;
end;
    ///////////////////////////////////////////////////////////////////////////////
   function LocalIP: String;
type
TaPInAddr = Array[0..10] of PInAddr;
PaPInAddr = ^TaPInAddr;
var
phe: PHostEnt;
pptr: PaPInAddr;
Buffer: Array[0..63] of Char;
I: Integer;
GInitData: TWSAData;
begin
WSAStartup($101, GInitData);
Result := '';
GetHostName(Buffer, SizeOf(Buffer));
phe := GetHostByName(buffer);
if phe = nil then Exit;
pPtr := PaPInAddr(phe^.h_addr_list);
I := 0;
while pPtr^[I] <> nil do
begin
Result := inet_ntoa(pptr^[I]^);
Inc(I);
end;
WSACleanup;
end;
 function Usuario: String;
//retorna el usuario logeado
var  NameBuf: array[ 0..60 ] of Char;
     SizeBuf: LongWord;
begin
     SizeBuf := Sizeof( NameBuf );
     GetUserName( NameBuf, SizeBuf );
     Result  := NameBuf ;
end;
end.

						