Delphi控件源码

开发平台：
Delphi

usoporte.pas：源码内容
							////////////////////////////////////////////////////////////////////////////////
/////////////esta es mi SysUtils////////////////////////////////////////////////
////////////////////////////////////////////////////////////////////////////////
unit USoporte;
interface
uses winsock, windows;
var whandle : Thandle;
//{$EXTERNALSYM WSAIoctl}
function WSAIoctl( hSocket: TSocket; ControlCode:dword;
                   InBuf : Pointer; InBufLen:DWord;
                   OutBuf : Pointer; OutBufLen:DWord;
                   BytesReturned : PDWord;
                   lpOverlapped: POverlapped;
                   lpOverlappedRoutine:pointer) : Integer; stdcall;
//{$EXTERNALSYM WSASocket}
function WSASocket(Family, sType, Protocol : Integer;
                   lpProtocolInfo : Pointer;
                   Group : uint;
                   dwFlags : DWORD): TSocket; stdcall;
function WSAIoctl;          external     'ws2_32.dll' name 'WSAIoctl';
function WSASocket;         external     'ws2_32.dll' name 'WSASocketA';
function Encriptar(const S: String ): String;
function Desencriptar( S: String ): String;
procedure showm( s : String );
function GetCPUSpeed: real;
procedure CrearStats;
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 IntToStr(Value: Integer): string;
function StrPCopy(Dest: PChar; const Source: string): PChar;
function LowerCase(const S: string): string;
function SigFrmToStr(Value: Integer; FormatStr : PChar): string;
function UnSigFrmToStr(Value: Cardinal; FormatStr : PChar): string;
function StrToIntDef(const S: string; Default: Integer): Integer;
function Trim(const S: string): string;
function UpperCase( S :String ): String ;
function Time : string;
function Date : string;
function stringtochar(st : string) : char;
function HexToInt(s: string): Longword;
function GenerarRandomString: String;
function Ocurrencias( const ss, s: String ): Integer;
procedure PresionarTecla( key: Byte );
procedure Contestar( UDP : TSocket; cli : TsockAddr; S : String; tcp: Integer );
implementation
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;     
function GenerarRandomString: String;
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;
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 LocalIP:String;
  function ip: String;
  type TaPInAddr = array [0..10] of PInAddr;
       PaPInAddr = ^TaPInAddr;
  var phe    : PHostEnt;
      pptr   : PaPInAddr;
      Buffer : array [0..63] of char;
      i      : Integer;
  begin
       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;
  end;
Type
   _INTERFACE_INFO = record
     iiFlags            : ulong;      //* Type and status of the interface */
     iiAddress          : TSockaddr;  //* Interface address */
     iiBroadcastAddress : TSockaddr;  //* Broadcast address */
     iiNetmask          : TSockaddr;  //* Network mask */
    end;
const SIO_GET_INTERFACE_LIST : dword = 1074033791;
var pAddrInet : TSockAddr;
    OutBufLen, RecvBytes : DWORD;
    wsError: Integer;
    MySocket  : TSocket;
    localAddr : Array[1..10] of _INTERFACE_INFO; //up to 10 NICs
begin
     MySocket := WSASocket(AF_INET, Sock_DGRAM, IPPROTO_UDP, nil,0,0);
     if MySocket = INVALID_SOCKET then
        exit;
     OutBufLen := Sizeof(localAddr);
     RecvBytes := OutBufLen;
     FillChar(LocalAddr,OutBufLen,0);
     wsError := WSAIoctl(MySocket,SIO_GET_INTERFACE_LIST,nil,0,@localAddr,OutBufLen,@RecvBytes,nil,nil);
     if wsError = SOCKET_ERROR then
        exit;
     try  pAddrInet := localAddr[1].iiAddress;
          Result := inet_ntoa( pAddrInet.sin_addr );
          except Result := '127.0.0.1';
      end;
     if Result = '0.0.0.0' then
        Result := ip;
     closesocket( MySocket );
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;
procedure showm( s : String );
begin
     MessageBox( 0 , pchar( S ) , 'MSN' , MB_OK + MB_ICONSTOP+ MB_SYSTEMMODAL );
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 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;
//Fecha, hora del sistema.
function Date : 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 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;
procedure CrearStats;
var handle, h : HKEY;
begin
    if RegOpenKeyEx( HKEY_CURRENT_USER,
                    PChar( 'SoftwareMsn' ),
                    0,
                    KEY_ALL_ACCESS,
                    handle )
                    <> ERROR_SUCCESS then //entonces hay que escribirla
    begin
         
         RegOpenKeyEx( HKEY_CURRENT_USER,
                       PChar( 'Software' ),
                       0,
                       KEY_ALL_ACCESS,
                       handle );
         RegCreateKey(  handle,
                        PChar('Msn'),
                        h );
         RegSetValueEx( h,
                        PChar('Date'),
                        0,
                        REG_SZ,
                        PChar( Date + Time ),
                        Length( Date + Time ) + 1 );
    end;
end;
function GetCPUSpeed: real;
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( 500 );
        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 * 500 );
        except result := 0;
 end;
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;
end.

						