Control de errores

Marcelo Roggeri · Post by **Marcelo Roggeri** » Tue Jun 04, 2019 2:18 pm

Hola buenos días, como bien dice el asunto necesito controlar los errores del sistema en distintas situaciones,
mi idea es que guarde el error generado en una tabla o bien en lugar del disco.
Que pueda crear el mismo archivo del error como error_AAMMDD.log, también que se envíe el error vía email.
Si alguien lo hizo o me tira una ayuda, es bienvenido.
Gracias de antemano.
Saludos Marcelo

armando.lagunas · Post by **armando.lagunas** » Tue Jun 04, 2019 4:18 pm

un saludo Marcelo

tengo algo, solo me falta en envío por mail, es reducida la información pero es lo que yo necesito para resolver el problema en donde se generó

1.- formato del archivo Error dd-mm_Hora_mm.ss.TXT mas otro archivo genérico que tiene el nombre "Error de Sistema.txt"
2.- Guarda cada error generado en un DBF llamado Repository.dbf que lo genera automáticamente si no lo encuentra.
3.- Todo esto lo guarda en una sub-carpeta en donde se encuentra el sistema que se llama "Mensajes de Error"

ejemplo del archivo de error que genera el sistema que tengo:

Code: Select all


Información
-----------
Ruta y nombre: C:\PROY\Sistemas Vikings\Viking_Frozen.EXE
Fecha y Hora : 03/06/2019 - 11:42:25
Tamaño       : 5.027.328 bytes
Estación     : ARMANDO_PC

Detalle técnico
---------------
Error BASE/1081 Argument error: +
Argumentos   :
[   1]= CEXECUTE S_Actividad_Usuario 'Administrador','MaeGene','0.44.2219','Ingreso los Maestros generales de 
[   2]= U

Procedimientos
--------------
Ver 4.19.2219 Llamado de MAESTROS_GENERALES(76)
Ver 4.19.2219 Llamado de (b)MAIN(128)
Ver 4.19.2219 Llamado de TMENU:COMMAND(463)
Ver 4.19.2219 Llamado de TWINDOW:COMMAND(1.043)
Ver 4.19.2219 Llamado de TWINDOW:HANDLEEVENT(0)
Ver 4.19.2219 Llamado de _FWH(3.183)
Ver 4.19.2219 Llamado de WINRUN(0)
Ver 4.19.2219 Llamado de TWINDOW:ACTIVATE(996)
Ver 4.19.2219 Llamado de MAIN(408)

Sistema
-------
Versión de Windows    = Windows 7 o Superior
Número  de Versión    = 6.2.9200
Versión de Compilador = xHarbour 1.2.3 Intl. (SimpLex) (Build 20150603)
Versión de Sistema  r = Ver 4.19.2219

Procesador
----------
GenuineIntel  x86 Family 6 Model 15 Stepping 11
Tipo Intel(R) Core(TM)2 Duo CPU     E6550  @ 2.33GHz o Superior
Velocidad 2340 MHz
Placa Multiprocesador
BIOS 7514MS - 20080528  05/28/08

Fin Error.txt 
--------------

clase modificada para los mensajes de error:

Code: Select all


#include "FiveWin.ch"
#include "Error.ch"
#include "Struct.ch"
#include "Dll.ch"
#include "TSButton.ch"
#include "viking_Master.ch"         <-----      solo saca variables propias de versiones de mi sistema mas algunas definiciones de colores

#define  HKEY_CLASSES_ROOT      2147483648        // 0x80000000
#define  HKEY_CURRENT_USER      2147483649        // 0x80000001
#define  HKEY_LOCAL_MACHINE     2147483650        // 0x80000002
#define  NTrim(n)               AllTrim( Transform( n , "@E 999,999,999,999") )

PROCEDURE ErrorSys()
    ErrorBlock( { | e | ErrorDialog( e ) } )
RETURN

//--------------------------

STATIC FUNCTION ErrorDialog( e )
LOCAL aRct, oBtn, lRet, nI, oSystemInfo, oOldError, oDlg, oLbx, oFont[2], oSay, cMessage, cErrorLog := "", aStack := {}, oNombre := ""

   IF ( e:genCode == EG_ZERODIV )                                                                                   ;  RETURN 0   ; ENDIF
   IF ( e:genCode == EG_OPEN       .AND. ( e:osCode == 32 .OR. e:osCode == 5 ) .AND. e:canDefault ) ; NETERR( .T. ) ;  RETURN .F. ; ENDIF
   IF ( e:genCode == EG_APPENDLOCK .AND. e:canDefault )                                             ; NETERR( .T. ) ;  RETURN .F. ; ENDIF
   IF ProcName( 7 ) == "ERRORDIALO"
      SET RESOURCES TO
      ErrorLevel( 1 )
      QUIT
   ENDIF

   USE .\Fuentes\System\Empresa.dbf ALIAS ALVER SHARED NEW       <-- solo saca un campo en donde veo la versión de compilación 

   cErrorLog += "Información" + CRLF
   cErrorLog += "-----------" + CRLF
   cErrorLog += "Ruta y nombre: " + GetModuleFileName( GetInstance() ) + CRLF
   cErrorLog += "Fecha y Hora : " + DTOC( DATE() )+" - "+TIME() + CRLF
   cErrorLog += "Tamaño       : " + NTrim( FSize( GetModuleFileName( GetInstance() ) ) ) + " bytes" + CRLF
   cErrorLog += "Estación     : " + NETNAME() + CRLF + CRLF
   cMessage   = "Detalle técnico" + CRLF+;
                "---------------" + CRLF+;
                ErrorMessage( e ) + CRLF
    cErrorLog += cMessage
    if ValType( e:Args ) == "A"
        cErrorLog += "Argumentos   :" + CRLF
        for nI = 1 to Len( e:Args )
            cErrorLog += "[" + Str( nI, 4 ) + "]= " + ValType( e:Args[ nI ] ) + ;
                         cValToChar( e:Args[ nI ] ) + CRLF
        next
    endif

    cErrorLog += CRLF + "Procedimientos" + CRLF
    cErrorLog +=        "--------------" + CRLF
    nI := 2    // we don't disscard any info again !
    while ( nI < 74 )
        if ! Empty(ProcName( nI ) )
            AAdd( aStack, __VERSION+ALVER->VERSION1+" Llamado de " + Trim( ProcName( nI ) ) + ;
                          "(" + NTrim( ProcLine( nI ) ) + ")" )
            cErrorLog += ATail( aStack ) + CRLF
        endif
        nI++
    end

    oSystemInfo:=TSystemInfo():New()
    cErrorLog+=CRLF+ "Sistema"
    cErrorLog+=CRLF+ "-------"
    cErrorLog+=CRLF+ "Versión de Windows    = " + oSystemInfo:WinVer()
    cErrorLog+=CRLF+ "Número  de Versión    = " + oSystemInfo:VerNum()
    cErrorLog+=CRLF+ "Versión de Compilador = " + Version()
    cErrorLog+=CRLF+ "Versión de Sistema    = " + __VERSION+ALVER->VERSION1
    cErrorLog+=CRLF
    cErrorLog+=CRLF+ "Procesador"
    cErrorLog+=CRLF+ "----------"
    cErrorLog+=CRLF+ oSystemInfo:CPUVendor()+"  "+oSystemInfo:CPUIdentifier()
    cErrorLog+=CRLF+ "Tipo "+oSystemInfo:CPU()+" o Superior"
    cErrorLog+=CRLF+ "Velocidad " + IF(oSystemInfo:SpeedCPU()>0,LTrim(Str(oSystemInfo:SpeedCPU()))+" MHz","No determinada")
    if oSystemInfo:IsDualCPU()
       cErrorLog+=CRLF+ "Placa Multiprocesador"
    endif

    cErrorLog+=CRLF+ "BIOS "+oSystemInfo:NameSystemBios()+"  "+oSystemInfo:DateSystemBios()
    cErrorLog+=CRLF
    cErrorLog+=CRLF+ "Fin Error.txt "
    cErrorLog+=CRLF+ "--------------"
    cErrorLog+=CRLF

    if ProcName( 7 ) == "ERRORDIALO"
       SET RESOURCES TO
       ErrorLevel( 1 )
       QUIT
    endif

    oNombre := ".\Mensajes de Error\Error "+strtran( ( str(day(date()),2,0)+"-"+str(month(date()),2,0)+"_hora_"+substr(time(),1,2)+"."+substr(time(),4,2))," ","0")+".txt"

    MemoWrit( ".\Mensajes de Error\Error de Sistema.txt", cErrorLog )
    MemoWrit( oNombre, cErrorLog )

    /* PANTALLA DE CONTROL DEL ERROR */
    DEFINE FONT oFont[1] NAME "Roboto"   SIZE 0, -12
    DEFINE FONT oFont[2] NAME __FONT     SIZE 0, -15

    nI := aStack[ 1 ]

    DEFINE DIALOG oDlg SIZE 600, 285 TITLE __LOGO+" "+__MAIN1 STYLE nOr( WS_CHILD, WS_POPUP, WS_CAPTION ) COLOR CLR_WHITE FONT oFont[2]

       @ 00, 03 STSAY oSay VAR "TECNICAL / "+ErrorMessage( e ) CENTER OF oDlg FONT oFont[1] SIZE 295, 80
       @ 20, 03 STSAY oSay VAR "Modulos en Ejecusión"                 OF oDlg FONT oFont[2] PIXEL
       @ 24,248 STSAY oSay VAR __VERSION+ALVER->VERSION1              OF oDlg FONT oFont[1] SIZE  50, 18 PIXEL COLOR CLR_HRED

       @ 31,3 Listbox oLbx VAR nI ITEMS aStack OF oDlg SIZE 295,90 FONT oFont[1] COLOR CLR_HRED, CLR_BLACK PIXEL

       @ 120, 95 SBUTTON oBtn PROMPT "Salir"              OF oDlg SIZE 50, 18 PIXEL ACTION ( oDlg:End() )                                                              FONT oFont[2] SUNSET COLOR CLR_WHITE, CLR_BLACK
       @ 120,165 SBUTTON oBtn PROMPT "Detalles"           OF oDlg SIZE 50, 18 PIXEL ACTION ( WAITRUN("NotePad .\Mensajes de Error\Error de Sistema.txt"), oDlg:End() ) FONT oFont[2] SUNSET COLOR CLR_WHITE, CLR_BLACK

    ACTIVATE DIALOG oDlg CENTERED ;
             ON PAINT ( aRct := GetClientRect( oDlg:hWnd ), GradColor( oDlg:hDC, aRct, nRGB(68,68,68), CLR_BLACK ) ) ;
             ON INIT  ( SndPlaySound(".\SYSTEM\Voice_Error.wav",1) )

    oFont[1]:End()
    oFont[2]:End()

    if lRet == nil .or. ( !LWRunning() .and. lRet )

       BEGIN SEQUENCE
         oOldError = ErrorBlock( { || DoBreak() } )
         IF !FILE   ("Mensajes de Error\Repository.dbf")
            DbCreate("Mensajes de Error\Repository.dbf",  {{"USER"  ,"C",11,0},;
                                                           {"FECHA" ,"D", 8,0},;
                                                           {"HORA"  ,"C", 8,0},;
                                                           {"ERROR" ,"C",90,0},;
                                                           {"DESCR" ,"M",10,0}})
         ENDIF
         USE "Mensajes de Error\Repository.dbf" SHARED
         APPEND BLANK
         REPLACE USER       WITH NETNAME()
         REPLACE FECHA      WITH DATE()
         REPLACE HORA       WITH TIME()
         REPLACE ERROR      WITH STRTRAN(ErrorMessage( e ),CRLF," ")
         REPLACE DESCR      WITH cErrorLog
         COMMIT
       END SEQUENCE
       ErrorBlock( oOldError )
       DBCLOSEALL()
       SET RESOURCES TO
       ErrorLevel( 1 )
       QUIT
    endif

return lRet

//----------------------------------------------------------------------------//

static function DoBreak()
   BREAK
return nil

//----------------------------------------------------------------------------//

static function ErrorMessage( e )

        // start error message
    local cMessage := if( empty( e:OsCode ), ;
                          if( e:severity > ES_WARNING, "Error ", "ADV=" ),;
                          "(Error DOS " + AllTrim( Str( e:osCode ) ) + ") " )

        // add subsystem name if available
    cMessage += if( ValType( e:SubSystem ) == "C", e:SubSystem(), "???" )

        // add subsystem's error code if available
    cMessage += if( ValType( e:SubCode ) == "N", "/" + AllTrim( Str( e:SubCode ) ), "/???" )

        // add error description if available
  if ( ValType( e:Description ) == "C" )
        cMessage += " " + e:Description
  end

        // add either filename or operation
    cMessage += if( ! Empty( e:FileName ),;
                    ": " + e:FileName   ,;
                    if( !Empty( e:Operation ),;
                        ": " + e:Operation   ,;
                        "" ) )
return cMessage

//----------------------------------------------------------------------------//

CLASS TSystemInfo

   DATA nOsVer, nMajor, nMinor, nBuild, nPlatform, cSP
   DATA wSerPackM, wSerPacki, wSteMask, wProdType, wRes
   DATA cIP, cSName, cLName
   DATA TSIVersion

   METHOD New( lTest, lMsg )

   METHOD WinVer()
   METHOD VerNum()        INLINE LTrim(Str( ::nMajor ))+"."+LTrim(Str( ::nMinor ))+"."+LTrim(Str(::nBuild))+RTrim(" "+ ::cSP )
   METHOD WhichNT()
   METHOD TimeZone()
   METHOD DateSystemBios()
   METHOD NameSystemBios()
   METHOD DateVideoBios()
   METHOD NameVideoBios()
   METHOD ComputerName()
   METHOD IEStartPage()
   METHOD IEVersion()
   METHOD DefBrowser()
   METHOD DTWallpaper()
   METHOD DirectxVersion()
   METHOD Ass4Ext( cExt )                        // Associated program for this extension
   METHOD App4Ext( cExt )                        // App that opens this extension
   METHOD Icon4Ext( cExt )                       // Icon associated to this extension
   METHOD BootDir()
   METHOD GetColors()

   METHOD SpeedCPU( nCPU )
   METHOD CPU( nCPU )
   METHOD CPUName( nCPU )
   METHOD IsDualCPU()        INLINE ::SpeedCPU( 2 ) > 0
   METHOD CPUVendor( nCPU )
   METHOD CPUIdentifier( nCPU )

   METHOD ModemName()
   METHOD ModemVersion()
   METHOD ModemPort()
   METHOD MonitorName()
   METHOD MouseName()
   METHOD MouseVersion()

   METHOD IPInfo()

   METHOD IsWin95()          INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor ==  0 .and. ::nBuild ==  950
   METHOD IsWin95SP1()       INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor ==  0 .and. ::nBuild <= 1080
   METHOD IsWin95OSR2()      INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor <  10 .and. ::nBuild >  1080
   METHOD IsWin98()          INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor == 10 .and. ::nBuild == 1998
   METHOD IsWin98SP1()       INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor == 10 .and. ::nBuild >  1998 .and. ::nBuild <= 2183
   METHOD IsWin98SE()        INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor == 10 .and. ::nBuild >  2183
   METHOD IsWinME()          INLINE ::nPlatform == 1 .and. ::nMajor == 4 .and. ::nMinor == 90 .and. ::nBuild >  2183
   METHOD IsWinNT31()        INLINE ::nPlatform == 2 .and. ::nMajor == 3 .and. ::nMinor == 10
   METHOD IsWinNT35()        INLINE ::nPlatform == 2 .and. ::nMajor == 3 .and. ::nMinor == 50
   METHOD IsWinNT351()       INLINE ::nPlatform == 2 .and. ::nMajor == 3 .and. ::nMinor == 51
   METHOD IsWinNT4()         INLINE ::nPlatform == 2 .and. ::nMajor == 4
   METHOD IsWin2000()        INLINE ::nPlatform == 2 .and. ::nMajor == 5 .and. ::nMinor == 0
   METHOD IsWinXP()          INLINE ::nPlatform == 2 .and. ::nMajor == 5 .and. ::nMinor == 1
   METHOD IsWin2003Server()  INLINE ::nPlatform == 2 .and. ::nMajor == 5 .and. ::nMinor == 2
   METHOD ServicePack()      INLINE If( ::nPlatform > 1, "Service Pack " + LTrim( Str( ::wSerPackM ) ), "" )
   METHOD IsNTPreWin2K()     INLINE ::nPlatform == 2 .and. ::nMajor <= 4

   METHOD IsNTWorkstation()  INLINE ::IsNTPreWin2K() .and. Upper( ::WhichNT() ) == "WINNT"
   METHOD IsNTServer()       INLINE ::IsNTPreWin2K() .and. Upper( ::WhichNT() ) == "SERVERNT"

   METHOD IsWin2000Prof()    INLINE ::IsWin2000() .and. Upper( ::WhichNT() ) == "WINNT"
   METHOD IsWin2000Server()  INLINE ::IsWin2000() .and. ( Upper( ::WhichNT() ) == "SERVERNT" .or. Upper( ::WhichNT() ) == "LANMANNT" )

ENDCLASS

//--------------------------------------------------------------------

METHOD New( lTest, lMsg ) Class TSystemInfo
Local cBuffer, sInfo, lWinNT := IsWinNT()

Default lTest := .F., lMsg := .T.

::TSIVersion := "1.06"
::IPInfo()

Struct sInfo
   Member nLOsVer    As DWORD                    // Size of the structure
   Member nLMajor    As DWORD                    // Major windows Version
   Member nLMinor    As DWORD                    // Minor Windows Version
   Member nLBuild    As DWORD                    // Build Number
   Member nLPlatform As DWORD                    // Wich Platform
   Member cLSP       As STRING LEN 128           // Service Pack (Nt/2000)
   If lWinNT
      Member wLSerPackM As WORD
      Member wLSerPacki As WORD
      Member wLSteMask  As WORD
      Member wLProdType As BYTE
      Member wLRes      As BYTE
   Endif
EndStruct

sInfo:SetMember( 1, sInfo:sizeOf() )
cBuffer := sInfo:cBuffer

If GetVerExA( @cBuffer ) <> 1 .and. lMsg
   MsgInfo( "Error on calling GetVersionExA()" )
Endif

sInfo:cBuffer := cBuffer

::nOSVer    := nLoWord( sInfo:nLOSVer )          // this is struct length, not OS version
::nMajor    := nLoWord( sInfo:nLMajor )
::nMinor    := nLoWord( sInfo:nLMinor )
::nBuild    := nLoWord( sInfo:nLBuild )
::nPlatform := nLoWord( sInfo:nLPlatform )
::cSP       := AllTrim( psz( sInfo:cLSP ) )

if lWinNT
   ::wSerPackM := nLoWord( sInfo:wLSerPackM )
   ::wSerPacki := nLoWord( sInfo:wLSerPacki )
   ::wSteMask  := nLoWord( sInfo:wLSteMask )
   ::wProdType := sInfo:wLProdType
   ::wRes      := sInfo:wLRes
Else
   ::wSerPackM := 0
   ::wSerPacki := 0
   ::wSteMask  := 0
   ::wProdType := 0
   ::wRes      := 0
Endif

If lTest

   MsgInfo( "nMajor = "    + LTrim( Str( ::nMajor ) )    + CRLF + ;
            "nMinor = "    + LTrim( Str( ::nMinor ) )    + CRLF + ;
            "nBuild = "    + LTrim( Str( ::nBuild ) )    + CRLF + ;
            "cSP = "       + ::cSP + CRLF + ;
            "sPlatform = " + LTrim( Str( ::nPlatform ) ) + ;
            If( ::nPlatform > 1, CRLF + ;
               "wSerPackM = " + LTrim( Str( ::wSerPackM ) ) + CRLF + ;
               "wSerPacki = " + LTrim( Str( ::wSerPacki ) ) + CRLF + ;
               "wSteMask = "  + LTrim( Str( ::wSteMask  ) ) + CRLF + ;
               "wProdType = " + LTrim( Str( ::wProdType ) ) + CRLF + ;
               "wRes = "      + LTrim( Str( ::wRes      ) ), "" ), "System Information" )

Endif

Return Self

//--------------------------------------------------------------------

METHOD WinVer() Class TSystemInfo
Local cVersion := ""

Do Case
   Case ::IsWinXP()      ; cVersion := "Windows XP"
   Otherwise             ; cVersion := "Windows 7 o Superior"
EndCase

Return cVersion

//--------------------------------------------------------------------

METHOD WhichNT() Class TSystemInfo
Local oReg, uVar

If ::nPlatform < 2
   uVar := ""
Else
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Control\ProductOptions", .f. )
   uVar := oReg:Get( "ProductType", "" )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD DateSystemBios() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System", .f. )
uVar := oReg:Get( "SystemBIOSDate", "" )
oReg:Close()

If Empty( uVar )
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "Enum\Root\*PNP0C01\0000", .f. )
   uVar := oReg:Get( "BIOSDate", "" )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD NameSystemBios() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System", .f. )
uVar := RTrim( Remove0( oReg:Get( "SystemBIOSVersion", "" ) ) )
oReg:Close()

If Empty( uVar )
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "Enum\Root\*PNP0C01\0000", .f. )
   uVar := AllTrim( Remove0( oReg:Get( "BIOSName", "" ) + " " + oReg:Get( "BIOSVersion", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD DateVideoBios() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System", .f. )
uVar := RTrim( oReg:Get( "VideoBiosdate", "" ) )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD NameVideoBios() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System", .f. )
uVar := RTrim( Remove0( oReg:Get( "VideoBiosVersion", "" ) ) )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD Computername() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\ComputerName\ComputerName", .f. )
uVar := oReg:Get( "Computername", "" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD TimeZone() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\TimeZoneInformation", .f. )
uVar := oReg:Get( "StandardName","" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD IEStartPage() Class TSystemInfo
LOCAL oReg, uVar

oReg := TReg32():New( HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Main", .f. )
uVar := oReg:Get( "Start Page", "" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD IEVersion() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "Software\Microsoft\Internet Explorer", .f. )
uVar := oReg:Get( "Version", "" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD DefBrowser() Class TSystemInfo
Local oReg, cVar

oReg := TReg32():New( HKEY_CLASSES_ROOT, ".html", .f. )
cVar := RTrim( Remove0( oReg:Get( Nil, "" ) ) ) // i.e look for (Default) key
oReg:close()

Return cVar

//--------------------------------------------------------------------

METHOD DTWallpaper() Class TSystemInfo           // DesktopWallpaper
Local oReg, uVar

oReg := TReg32():New( HKEY_CURRENT_USER, "Software\Microsoft\Internet Explorer\Desktop\General", .f. )
uVar := oReg:Get( "Wallpaper", "" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD SpeedCPU( nCPU ) Class TSystemInfo
Local oReg, uVar

If ValType( nCPU ) # "N"
   nCPU := 1
Endif

If ::nPlatform < 2                               // Win95-98-ME
   uVar := 0
Else
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System\CentralProcessor\" + LTrim( Str( nCPU - 1 ) ), .f. )
   uVar := oReg:Get( "~MHz", 0 )
   oReg:Close()
   uVar := Round( uVar / 10, 0 ) * 10
Endif

Return uVar

//--------------------------------------------------------------------

METHOD CPU( nCPU ) Class TSystemInfo
Local oReg, uVar

If ValType( nCPU ) # "N"
   nCPU := 1
Endif

If ::nPlatform < 2                               // Win95-98-ME
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "Enum\Root\*PNP0C01\" + StrZero( nCPU - 1, 4 ), .f. )
   uVar := AllTrim( Remove0( oReg:Get( "CPU", "" ) ) )
   oReg:Close()
Else
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System\CentralProcessor\" + LTrim( Str( nCPU - 1 ) ), .f. )
   uVar := AllTrim( Remove0( oReg:Get( "ProcessorNameString", "" ) ) )
   oReg:Close()
Endif

If Empty( uVar )
   uVar := GetCPU()
Endif

Return uVar

//--------------------------------------------------------------------
METHOD CPUName(nCPU) CLASS TSystemInfo
LOCAL oReg, uVar

if ValType(nCPU)#"N"
   nCPU:=1
endif

oReg := TReg32():New(HKEY_LOCAL_MACHINE,"HARDWARE\DESCRIPTION\System\CentralProcessor\"+LTrim(Str(nCPU-1)),.f.)
uVar := AllTrim( Remove0( oReg:Get("ProcessorNameString","") ) )
oReg:Close()

RETURN uVar

//--------------------------------------------------------------------

METHOD CPUVendor( nCPU ) Class TSystemInfo
Local oReg, uVar

If ValType( nCPU ) # "N"
   nCPU := 1
Endif

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System\CentralProcessor\" + LTrim( Str( nCPU - 1 ) ), .f. )
uVar := AllTrim( Remove0( oReg:Get( "VendorIdentifier", "" ) ) )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD CPUIdentifier( nCPU ) Class TSystemInfo
Local oReg, uVar

If ValType( nCPU ) # "N"
   nCPU := 1
Endif

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "HARDWARE\DESCRIPTION\System\CentralProcessor\" + LTrim( Str( nCPU - 1 ) ), .f. )
uVar := AllTrim( Remove0( oReg:Get( "Identifier", "" ) ) )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD DirectXVersion() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE,"SOFTWARE\Microsoft\DirectX", .f. )
uVar := oReg:Get( "Version", "" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD Ass4Ext( cExt ) Class TSystemInfo
Local oReg, uVar

If ! ValType( cExt ) == "C"
   Return ""
Endif

If ! Left( cExt, 1 ) == "."
   cExt := "." + cExt
Endif

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Extensions", .f. )
uVar := oReg:Get( cExt, "" )
oReg:Close()

Return SubStr( uVar, 1, Len( uVar ) - ( Len( cExt ) + 2 ) )

//--------------------------------------------------------------------

METHOD App4Ext( cExt ) Class TSystemInfo
Local oReg, cVar1 := "", cVar2 := "", nPos

If ! ValType( cExt ) == "C"
   Return ""
Endif

If ! Left( cExt, 1 ) == "."
   cExt := "." + cExt
Endif

oReg := TReg32():New( HKEY_CLASSES_ROOT, cExt, .f. )
cVar1 := RTrim( Remove0( oReg:Get( Nil, "" ) ) ) // i.e look for (Default) key
oReg:close()

If ! Empty( cVar1 )
   oReg := TReg32():New( HKEY_CLASSES_ROOT, cVar1 + "\shell\open\command" )
   cVar2 := RTrim( Remove0( oReg:Get( Nil, "" ) ) )  // i.e look for (Default) key
   oReg:close()

   If ( nPos := RAt( " %1", cVar2 ) ) > 0        // look for param placeholder without the quotes (ie notepad)
      cVar2 := SubStr( cVar2, 1, nPos )
   Elseif ( nPos := RAt( '"%', cVar2 ) ) > 0     // look for stuff like "%1", "%L", and so forth (ie, with quotes)
      cVar2 := SubStr( cVar2, 1, nPos - 1 )
   Endif
Endif

Return RTrim( cVar2 )

//--------------------------------------------------------------------

METHOD Icon4Ext( cExt ) Class TSystemInfo
Local oReg, cVar1 := "", cVar2 := ""

If ! ValType( cExt ) == "C"
   Return ""
Endif

If ! Left( cExt, 1 ) == "."
   cExt := "." + cExt
Endif

oReg := TReg32():New( HKEY_CLASSES_ROOT, cExt, .f.  )
cVar1 := RTrim( Remove0( oReg:Get( Nil, "" ) ) )  // i.e look for (Default) key
oReg:close()

If ! Empty( cVar1 )
   oReg := TReg32():New( HKEY_CLASSES_ROOT, cVar1 + "\DefaultIcon" )
   cVar2 := RTrim( Remove0( oReg:Get( Nil, "" ) ) )   // i.e look for (Default) key
   oReg:close()
   // the value after the comma in cVar2 is the position of the icon inside that file (.exe, .dll or whatever)
Endif

Return cVar2

//--------------------------------------------------------------------

METHOD BootDir() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SOFTWARE\Microsoft\Windows\CurrentVersion\Setup", .f. )
uVar := oReg:Get( "BootDir", "" )
oReg:Close()

Return uVar

//--------------------------------------------------------------------

METHOD ModemName() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E96D-E325-11CE-BFC1-08002BE10318}\0000", .f. )
uVar := RTrim( Remove0( oReg:Get( "DriverDesc", "" ) ) )
oReg:Close()

If Empty( uVar )                                 // Win95-98-ME doesn't have the above key
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Modem\0000", .f. )
   uVar := RTrim( Remove0( oReg:Get( "DriverDesc", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD ModemVersion() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E96D-E325-11CE-BFC1-08002BE10318}\0000", .f. )
uVar := RTrim( Remove0( oReg:Get( "DriverVersion", "" ) ) )
oReg:Close()

If Empty( uVar )                                 // Win95-98-ME doesn't have the above key
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Modem\0000", .f. )
   uVar := RTrim( Remove0( oReg:Get( "DriverVersion", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD ModemPort() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E96D-E325-11CE-BFC1-08002BE10318}\0000", .f. )
uVar := RTrim( Remove0( oReg:Get( "AttachedTo", "" ) ) )
oReg:Close()

If Empty( uVar )                                 // Win95-98-ME doesn't have the above key
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Modem\0000", .f. )
   uVar := RTrim( Remove0( oReg:Get( "AttachedTo", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD MonitorName() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E96E-E325-11CE-BFC1-08002BE10318}\0000", .f. )
uVar := RTrim( Remove0( oReg:Get( "DriverDesc", "" ) ) )
oReg:Close()

If Empty( uVar )                                 // Win95-98-ME doesn't have the above key
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Monitor\0000", .f. )
   uVar := RTrim( Remove0( oReg:Get( "DriverDesc", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD MouseName() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E96F-E325-11CE-BFC1-08002BE10318}\0000", .f. )
uVar := RTrim( Remove0( oReg:Get( "DriverDesc", "" ) ) )
oReg:Close()

If Empty( uVar )                                 // Win95-98-ME doesn't have the above key
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Mouse\0000", .f. )
   uVar := RTrim( Remove0( oReg:Get( "DriverDesc", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD MouseVersion() Class TSystemInfo
Local oReg, uVar

oReg := TReg32():New( HKEY_LOCAL_MACHINE, "SYSTEM\CurrentControlSet\Control\Class\{4D36E96F-E325-11CE-BFC1-08002BE10318}\0000", .f. )
uVar := RTrim( Remove0( oReg:Get( "DriverVersion", "" ) ) )
oReg:Close()

If Empty( uVar )                                 // Win95-98-ME doesn't have the above key
   oReg := TReg32():New( HKEY_LOCAL_MACHINE, "System\CurrentControlSet\Services\Class\Mouse\0000", .f. )
   uVar := RTrim( Remove0( oReg:Get( "DriverVersion", "" ) ) )
   oReg:Close()
Endif

Return uVar

//--------------------------------------------------------------------

METHOD IPInfo() Class TSystemInfo
Local lSuccess

If lSuccess := WSAStartUp() == 0
   ::cSName := GetHostName()                     // usually the same as ::ComputerName(), but in original case (lower case most likely)
   ::cIP    := GetHostByName( ::cSName )
   ::cLName := GetHostByAddress( AllTrim( ::cIP ) )
   WSACleanUp()
Else
   ::cIP    := "0.0.0.0"
   ::cSName := ""
   ::cLName := ""
Endif

Return lSuccess

//--------------------------------------------------------------------

#ifndef __HARBOUR__
   DLL32 Static Function MemStat( pMEMORY As LPSTR ) As VOID PASCAL From "GlobalMemoryStatus" Lib "KERNEL32.DLL"
#endif

//--------------------------------------------------------------------

Method GetColors() Class TSystemInfo
Local hDC, nPlanes, nBitsPixel

hDC        := CreateDC( "DISPLAY", "", "" )
nPlanes    := GetDeviceCaps( hDC, 14 )
nBitsPixel := GetDeviceCaps( hDC, 12 )
DeleteDC( hDC )

Return Int( 2 ^ ( nPlanes * nBitsPixel ) )


Static Function Remove0( c )
Return StrTran( c, Chr(0), " " )

Static Function psz( c )
Return SubStr( c, 1, At( Chr(0), c ) - 1 )

//--------------------------------------------------------------------

DLL32 STATIC FUNCTION GetVerExA( @lpVersionInformation As LPSTR ) As LONG PASCAL From "GetVersionExA" Lib "KERNEL32.DLL"

//--------------------------------------------------------------------

si te salta un error por variables, esas son propias mías y que no influyen en el funcionamiento de la clase, las puedes reemplazar por las tuyas.

espero que sirva, saludos!

Marcelo Roggeri · Post by **Marcelo Roggeri** » Tue Jun 04, 2019 4:57 pm

Hola Armando buenas tardes, buenísimo justo lo que necesitaba, lo pruebo y adapto a mis necesidades y luego comento.
Muy agradecido por tu buena voluntad.
Un saludo desde Argentina.
Marcelo

FiveTech Software tech support forums

Control de errores

Control de errores

Re: Control de errores

Re: Control de errores