Fiz uma modificação na ErrorSys do Fivewin de forma a não apresentar aquela tela de erros padrão e sim uma tela com as caracteristicas da mensagem de erros do Internet Explorer 6 que pede para enviar um relatório e tudo mais.
Codigo .RC do Dialogo principal
dlgMSRel DIALOG 20, 28, 245, 138
STYLE 0x4L | WS_POPUP | WS_VISIBLE | WS_CAPTION | WS_SYSMENU | WS_THICKFRAME
CAPTION "Mensagem de Erro"
FONT 8, "MS Sans Serif"
{
CONTROL "", 100, "static", SS_WHITERECT | WS_CHILD | WS_VISIBLE, -8, -1, 261, 30
ICON "icon_info", -1, 4, 3, 18, 20
LTEXT "Evento de detecção de erros", 99, 28, 3, 224, 24
PUSHBUTTON "&Enviar relatório de erros", 1, 4, 121, 114, 14, NOT WS_TABSTOP
DEFPUSHBUTTON "&Não enviar", 2, 120, 121, 52, 14, BS_DEFPUSHBUTTON | NOT WS_TABSTOP
CONTROL "", -1, "BorShade", BSS_HDIP | BSS_LEFT | WS_CHILD | WS_VISIBLE, -3, 29, 254, 5
LTEXT "O programa não responde.", -1, 4, 35, 247, 9
LTEXT "Informe este problema à Empresa X.", -1, 5, 52, 247, 9
LTEXT "Foi criado um relatório detalhando o erro ocorrido que voce pode nos enviar para ajudar a melhorar o meu sistema. Esse relatório será considerado confidencial e anônimo.", -1, 5, 66, 241, 29
LTEXT "Para visualizar os dados contidos neste relatório de erros.", -1, 5, 99, 181, 9
PUSHBUTTON "Clique aqui.", 3, 188, 96, 43, 14
CONTROL "", -1, "BorShade", BSS_HDIP | BSS_LEFT | WS_CHILD | WS_VISIBLE, 3, 116, 240, 3
PUSHBUTTON "&Denovo", 4, 173, 121, 34, 14, WS_DISABLED | WS_TABSTOP
PUSHBUTTON "&Padrão", 5, 209, 121, 34, 14, WS_DISABLED | WS_TABSTOP
}
Codigo da ErrorSys completo.
// Error handler system adapted to FiveWin
// Modificado por BINGEN - Mungia Informática 1.999-2.002
// Adaptación Clipper 5.2 por WILLIAMS PACHECO 2.003
// Remodelado por Jose Carlos da Rocha - SoHome Informatica Jul-2005
// ErrSysW.prg
STATIC lWin2000
#include "error.ch"
#include "dll.ch"
#include "FiveWin.ch"
//----------------------------------------------------------------------------//
#xcommand PRINT [ <oPrint> ] ;
[ <name: NAME, TITLE,DOC> <cDocument> ] ;
[ <user: FROM USER> ] ;
[ <prvw: PREVIEW> [<lmodal: MODAL>] ] ;
[ TO <xModel> ] ;
=> ;
[ <oPrint> := ] PrintBegin( [<cDocument>], <.user.>, <.prvw.>, <xModel>, <.lmodal.> )
#xcommand PRINTER [ <oPrint> ] ;
[ <name: NAME, DOC> <cDocument> ] ;
[ <user: FROM USER> ] ;
[ <prvw: PREVIEW> [<lmodal: MODAL>] ] ;
[ TO <xModel> ] ;
=> ;
[ <oPrint> := ] PrintBegin( [<cDocument>], <.user.>, <.prvw.>, <xModel>, <.lmodal.> )
#xcommand PAGE => PageBegin()
#xcommand ENDPAGE => PageEnd()
#xcommand ENDPRINT => PrintEnd()
#xcommand ENDPRINTER => PrintEnd()
//----------------------------------------------------------------------------//
#define GHW_HWNDFIRST 0
#define GHW_HWNDNEXT 2
#define GWW_HINSTANCE -6
external _fwGenError // Link FiveWin generic Error Objects Generator
#define NTRIM(n) ( LTrim( Str( n ) ) )
/*************
* ErrorSys()
*
* Note: automatically executes at startup
*/
proc ErrorSys()
ErrorBlock( { | e | ErrorDialog( e ) } )
return
proc ErrorLink()
return
/*************
* ErrorDialog()
*/
static function ErrorDialog( e ) // -> logical or quits App.
local oDlg, oLbx, oFont
local lRet // if lRet == nil -> default action: QUIT
local n, j, cMessage, aStack := {}
local oSay, hLogo
local nButtons := 1
local cErrorLog := ""
local aVersions := {}
local aTasks := {}
local aRDDs, nTarget, uValue
local oOldError
local cRelation
local lIsWinNT := .f.
local oSystemInfo
local oWnd := WndMain()
local hBmp, hDib, cImgFile
local aScreens:=array(0), nScreens:=30 //Hasta 30 pantallas guardadas
// Definimos cUser por si acaso el sistema no maneja este valor (WP)
cUser := if( Type( "cUser" ) <> "C", "N/D", cUser )
// Por defecto la división entre 0 devuelve 0
if ( e:genCode == EG_ZERODIV )
return 0
endif
// for network open error, set NETERR() and subsystem default
if ( e:genCode == EG_OPEN .and. ;
( e:osCode == 32 .or. e:osCode == 5 ) .and. e:canDefault )
NetErr( .t. )
return .f. // OJO SALIDA
end
// for lock error during APPEND BLANK, set NETERR() and subsystem default
if ( e:genCode == EG_APPENDLOCK .and. e:canDefault )
NetErr( .t. )
return .f. // OJO SALIDA
endif
aTasks := GetTasks()
lIsWinNT := IsWinNT()
aVersions := GetVersion()
/* DESCRIPCIÓN DEL ERROR */
cErrorLog += "Dados do erro causado pela aplicacao" + CRLF
cErrorLog += oWnd:cTITLE + CRLF
cErrorLog += "-----------------------------------------" + CRLF
cErrorLog += " Caminho : " + GetModuleFileName( GetInstance() ) + CRLF
cErrorLog += " Tamanho : " + Transform( FSize( GetModuleFileName( GetInstance() ) ), "9,999,999 bytes" ) + CRLF
cErrorLog += " Max files : " + Str( SetHandleCount(), 3 ) + CRLF
cErrorLog += " Data e Hora : " + DToC( Date() ) + ", " + Time() + CRLF
cErrorLog += " Estacao : " + NETNAME() + CRLF+ CRLF
// Error object analysis
cMessage = "Descricao do erro produzido" + CRLF+;
"-------------------------------" + CRLF+;
" "+ErrorMessage( e ) + CRLF
cErrorLog += cMessage
if ValType( e:Args ) == "A"
cErrorLog += " Argumentos :" + CRLF
for n = 1 to Len( e:Args )
cErrorLog += " [" + Str( n, 4 ) + "] = " + ValType( e:Args[ n ] ) + ;
" " + cValToChar( e:Args[ n ] ) + CRLF
next
endif
cErrorLog += CRLF + "Chamadas ao Stack" + CRLF
cErrorLog += "-----------------" + CRLF
n := 2 // we don't disscard any info again !
while ( n < 74 )
if ! Empty(ProcName( n ) )
AAdd( aStack, " Called from " + Trim( ProcName( n ) ) + ;
"(" + NTRIM( ProcLine( n ) ) + ")" )
cErrorLog += ATail( aStack ) + CRLF
endif
n++
end
oSystemInfo:=TSystemInfo():New()
cErrorLog+=CRLF+ "Informacao do sistema."
cErrorLog+=CRLF+ "------------------------"
cErrorLog+=CRLF+ " Versao do Windows = " + oSystemInfo:WinVer()
cErrorLog+=CRLF+ " Numero da versao = " + oSystemInfo:VerNum()
cErrorLog+=CRLF
cErrorLog+=CRLF+ "Processador do sistema."
cErrorLog+=CRLF+ "-----------------------"
cErrorLog+=CRLF+ " "+oSystemInfo:CPUVendor()+ " "+oSystemInfo:CPUIdentifier()
cErrorLog+=CRLF+ " Tipo "+oSystemInfo:CPU()+" o Superior"
cErrorLog+=CRLF+ " Velocidade " + IF(oSystemInfo:SpeedCPU()>0,LTrim(Str(oSystemInfo:SpeedCPU()))+" MHz","No determinada")
if oSystemInfo:IsDualCPU()
cErrorLog+=CRLF+ " Placa Base Multiprocesador "
endif
cErrorLog+=CRLF+ " BIOS "+oSystemInfo:NameSystemBios()+" "+oSystemInfo:DateSystemBios()
cErrorLog+=CRLF
cErrorLog+=CRLF+ "Informacao da Memoria"
cErrorLog+=CRLF+ "-------------------------"
cErrorLog+=CRLF+ " Memoria RAM :"+LTrim(Str(oSystemInfo:Memory(1),6,0))+" MB"+;
" Disponivel : "+LTrim(Str(oSystemInfo:Memory(2),6,0))+" MB"
cErrorLog+=CRLF+ " Memoria Virtual : "+ LTrim(Str(oSystemInfo:Memory(5),6,0))+" MB"+;
" Disponivel : "+LTrim(Str(oSystemInfo:Memory(6),6,0))+" MB"
cErrorLog+=CRLF+ " Paginacao de arquivos: " + LTrim(Str(oSystemInfo:Memory(3),6,0))+" MB"+;
" Disponivel :"+LTrim(Str(oSystemInfo:Memory(4),6,0))+" MB"
cErrorLog+=CRLF
cErrorLog+=CRLF+ " Memoria estatica:"
cErrorLog+=CRLF+ " Segmento de dados : 64k"
cErrorLog+=CRLF+ " Tamanho inicial : " + LTrim( Str( nInitDSSize() ) ) + ;
" bytes (SYMP=" + LTrim( Str( nSymPSize() ) ) + ;
", Stack=" + LTrim( Str( nStackSize() ) ) + ;
", Heap=" + LTrim( Str( nHeapSize() ) ) + ")"
cErrorLog+=CRLF+ " Stack do Programa : " + LTrim( Str( 65535 - ( nStatics() * 14 ) - nInitDSSize() ) ) + " bytes"
cErrorLog+=CRLF+ " " + LTrim( Str( nStatics() ) ) + " Variables estáticas : " +LTrim( Str( nStatics() * 14 ) ) + " bytes"
cErrorLog+=CRLF
cErrorLog+=CRLF+ " Consumo de memoria dinámica:"
cErrorLog+=CRLF+ " Valor atual : " + Str( MemUsed() ) + " bytes"
cErrorLog+=CRLF+ " Maior possivel : " + Str( MemMax() ) + " bytes"
cErrorLog+=CRLF
cErrorLog+=CRLF+ " Recursos do Sistema " + AllTrim( Str( GetFreeSystemResources( 0 ) ) ) +" %"+ ;
" GDI " + AllTrim( Str( GetFreeSystemResources( 1 ) ) ) +" %"+;
" Usuario " + AllTrim( Str( GetFreeSystemResources( 2 ) ) ) +" %"
cErrorLog+=CRLF
cErrorLog+=CRLF+ "Total de aplicacoes Windows em ejecucao: " + Str( GetNumTasks(), 3 )
cErrorLog+=CRLF+ "--------------------------------------------------"
cErrorLog+=CRLF
for n = 1 to Len( aTasks )
cErrorLog += " " + Str( n, 3 ) + " " + aTasks[ n ] + CRLF
next
if ProcName( 7 ) == "ERRORDIALO" // recursive error !!!
SET RESOURCES TO
ErrorLevel( 1 )
QUIT // must be QUIT !!!
endif
// Warning!!! Keep here this code !!! Or we will be consuming GDI as
// we don't generate the error but we were generating the bitmap
hLogo = FWBitMap()
if e:canRetry
nButtons++
endif
if e:canDefault
nButtons++
endif
cErrorLog += CRLF + "Variables em uso" + CRLF + ;
"----------------" + CRLF
cErrorLog += " Procedure Tipo Valor" + CRLF
cErrorLog += " ==========================" + CRLF
n := 2 // we don't disscard any info again !
while ( n < 74 )
if ! Empty( ProcName( n ) ) .AND. ProcName( n )<>"ERRORDIALO"
cErrorLog += " " + Trim( ProcName( n ) ) + CRLF
for j = 1 to ParamCount( n )
cErrorLog += " Param " + Str( j, 3 ) + ": " + ;
ValType( GetParam( n, j ) ) + ;
" " + cGetInfo( GetParam( n, j ) ) + CRLF
next
for j = 1 to LocalCount( n )
cErrorLog += " Local " + Str( j, 3 ) + ": " + ;
ValType( GetLocal( n, j ) ) + ;
" " + cGetInfo( GetLocal( n, j ) ) + CRLF
next
endif
n++
end
cErrorLog += CRLF + "RDDs Linkados" + CRLF + ;
"-------------" + CRLF
aRDDs = RddList( 1 )
for n = 1 to Len( aRDDs )
cErrorLog += " " + aRDDs[ n ] + CRLF
next
cErrorLog += CRLF + "DataBases em uso" + CRLF + ;
"----------------" + CRLF
for n = 1 to 255
if ! Empty( Alias( n ) )
cErrorLog += CRLF + Str( n, 3 ) + ": " + If( Select() == n,"=> ", " " ) + ;
PadR( Alias( n ), 15 ) + Space( 20 ) + "RddName: " + ;
( Alias( n ) )->( RddName() ) + CRLF
cErrorLog += " ==============================" + CRLF
cErrorLog += " RecNo RecCount BOF EOF" + CRLF
cErrorLog += " " + Transform( ( Alias( n ) )->( RecNo() ), "99999" ) + ;
" " + Transform( ( Alias( n ) )->( RecCount() ), "99999" ) + ;
" " + cValToChar( ( Alias( n ) )->( BoF() ) ) + ;
" " + cValToChar( ( Alias( n ) )->( EoF() ) ) + CRLF + CRLF
cErrorLog += " Indices em uso " + Space( 23 ) + "TagName" + CRLF
for j = 1 to 15
if ! Empty( ( Alias( n ) )->( IndexKey( j ) ) )
cErrorLog += Space( 8 ) + ;
If( ( Alias( n ) )->( IndexOrd() ) == j, "=> ", " " ) + ;
PadR( ( Alias( n ) )->( IndexKey( j ) ), 35 ) + ;
( Alias( n ) )->( OrdName( j ) ) + ;
CRLF
endif
next
cErrorLog += CRLF + " Relaciones em uso" + CRLF+;
" ================="
for j = 1 to 8
if ! Empty( ( nTarget := ( Alias( n ) )->( DbRSelect( j ) ) ) )
cErrorLog += Space( 8 ) + Str( j ) + ": " + ;
"TO " + ( Alias( n ) )->( DbRelation( j ) ) + ;
" INTO " + Alias( nTarget ) + CRLF
// uValue = ( Alias( n ) )->( DbRelation( j ) )
// cErrorLog += cValToChar( &( uValue ) ) + CRLF
endif
next
endif
next
n = 1
cErrorLog += CRLF + "Clases em uso" + CRLF
cErrorLog += "-------------" + CRLF
while ! Empty( __ClassNam( n ) )
cErrorLog += " " + Str( n, 3 ) + " " + __ClassNam( n++ ) + CRLF
end
/* GRABAR FICHERO DEL ERROR*/
MemoWrit( "Error.log", cErrorLog )
/* PANTALLA DE CONTROL DEL ERROR */
DEFINE FONT oFont NAME "Ms Sans Serif" SIZE 0, -10
DEFINE DIALOG oDlg RESOURCE "dlgMSRel"
REDEFINE SAY oSay VAR "O seguinte erro foi encontrado:"+CRLF+ErrorMessage( e ) ID 99 OF oDlg COLOR RGB(000,000,000),RGB(255,255,255)
REDEFINE SAY oSay ID 100 OF oDlg COLOR RGB(255,255,255),RGB(000,000,000)
REDEFINE BUTTON oBtn1 ID 1 OF oDlg ACTION (;
CheckPop3( 'pop.sao.terra.com.br', 'jscrocha', 'claudete',;
{ |o| If( SubStr( o:cStatus, 1, 3 ) == "+OK",;
SendEmailRel( cEmail, cMensagem, cHost, cReplyTo, cSubject, cMsg, lReceipt, lAuth, cUser, cPass, lPop3, cPOP3Host ), MsgStop( "Login POP3 falhou." ) ) } ), oDlg:End())
REDEFINE BUTTON oBtn2 ID 2 OF oDlg ACTION oDlg:End()
REDEFINE BUTTON oBtn3 ID 3 OF oDlg ACTION WAITRUN("NOTEPAD ERROR.LOG") NOBORDER
REDEFINE BUTTON oBtn4 ID 4 OF oDlg ACTION ( lRet := .t., oDlg:End() ) // Retry
REDEFINE BUTTON oBtn5 ID 5 OF oDlg ACTION ( lRet := .f., oDlg:End() ) // Default
ACTIVATE DIALOG oDlg CENTERED ON INIT ( iif(e:CanRetry,oBtn4:Enable(),oBtn4:Disable()), iif(e:CanDefault,oBtn4:Enable(),oBtn4:Disable()) )
/*
DEFINE DIALOG oDlg ;
SIZE 300, 260 + If( lIsWinNT, 50, 0 ) ;
TITLE "Control de errores del programa" ;
FONT oFont
@ 0, 0 SAY oSay PROMPT "O seguinte erro foi encontrado:"+CRLF+ErrorMessage( e ) ;
CENTERED OF oDlg FONT oFont SIZE 149, 45
oSay:nStyle = nOR( oSay:nStyle, 128 ) // SS_NOPREFIX
oSay:nTop = 3
oSay:nLeft = 22
oSay:nBottom = 25
oSay:nRight = 148
@ 34, 6 SAY "&Lista do Stack" OF oDlg FONT oFont PIXEL
@ 34, 90 SAY "Veja no arquivo Error.log" OF oDlg FONT oFont PIXEL
n = aStack[ 1 ]
@ 43, 3 LISTBOX oLbx VAR n ITEMS aStack OF oDlg ;
SIZE 145, 60 + If( lIsWinNT, 18, 0 ) PIXEL
if nButtons == 1 .or. nButtons == 3
@ 100 + If( lIsWinNT, 24, 0 ), 60 BUTTON "&Sair" OF oDlg ACTION oDlg:End() ;
SIZE 30, 12 PIXEL FONT oFont DEFAULT
else
@ 100 + If( lIsWinNT, 24, 0 ), 37 BUTTON "&Sair" OF oDlg ACTION oDlg:End() ;
SIZE 30, 12 PIXEL FONT oFont
endif
if e:CanRetry
@ 100 + If( lIsWinNT, 24, 0 ), If( nButtons == 2, 82, 13 ) BUTTON "&Denovo" ;
OF oDlg ACTION ( lRet := .t., oDlg:End() ) ;
SIZE 30, 12 FONT oFont PIXEL
endif
if e:CanDefault
@ 100 + If( lIsWinNT, 24, 0 ), 108 BUTTON "&Default" OF oDlg ;
ACTION ( lRet := .f., oDlg:End() ) ;
SIZE 30, 12 FONT oFont PIXEL
endif
@ 115 + If( lIsWinNT, 24, 0 ), 40 BUTTON "&Enviar Relatorio" OF oDlg ;
ACTION ( oDlg:End(),SendRel() ) ;
SIZE 70, 12 FONT oFont PIXEL
//@ 115 + If( lIsWinNT, 24, 0 ), 40 BUTTON "&Ver/Imprimir Error.log" OF oDlg ;
// ACTION ( oDlg:End(),WAITRUN("NOTEPAD ERROR.LOG") ) ;
// SIZE 70, 12 FONT oFont PIXEL
ACTIVATE DIALOG oDlg CENTERED ;
ON PAINT DrawBitmap( hDC, hLogo, 6, 6 )
DeleteObject( hLogo )
*/
oFont:End()
if lRet == nil .or. ( !LWRunning() .and. lRet )
BEGIN SEQUENCE
oOldError = ErrorBlock( { || DoBreak() } )
/* CONTROL PERSONALIZADO DE ERRORES */
if !lIsDir( "ERRORES" ) //CREAR CARPETA DE ERRORES DEL PROGRAMA
lMkDir( "ERRORES" )
endif
IF cUser <> "DPD" //NO SE GRABAN SI SOMOS NOSOTROS
IF !FILE("ERRORES\ERRORES.DBF")
DbCreate("ERRORES\ERRORES.DBF",;
{{"Usuario","C",11,0},{"Fecha","D",8,0},;
{"Hora","C",8,0},{"Descripcio","C",76,0},;
{"Trazo","M",10,0},{"Pantalla","C",30,0} })
ENDIF
SET PRINTER OFF
SET CONSOLE ON
USE "ERRORES\ERRORES.DBF" SHARED
APPEND BLANK
REPLACE USUARIO WITH NETNAME()
REPLACE FECHA WITH DATE()
REPLACE HORA WITH TIME()
REPLACE DESCRIPCIO WITH STRTRAN(ErrorMessage( e ),CRLF," ")
REPLACE TRAZO WITH cERRORLOG
// Funcion de reemplazo para guardar la imagen (WP)
hBmp := WndBitmap( oWnd:hWnd )
hDib := DibFromBitmap( hBmp )
cImgFile := "ERR" + StrZero( RecNo(), 5 )
//Borrar exceso de pantallas
aScreens:=DIRECTORY("ERRORES\*.JPG")
aScreens:=ASORT(aScreens,,, { |x, y| x[1] < y[1] })
FOR nScreen:=1 TO LEN(aScreens)-nScreens
DELETE FILE ("ERRORES\"+aScreens[nScreen,1])
NEXT
REPLACE PANTALLA WITH SalvarBmp( hDib, cImgFile, "JPG" )
COMMIT
ENDIF
END SEQUENCE
ErrorBlock( oOldError )
/* CERRAR MDICHILD FICHEROS Y RECURSOS Y SALIR */
// if TYPE( "oMainWnd" ) = "O"
oWnd:CLOSEALL()
// endif
DBCLOSEALL()
SET RESOURCES TO
ErrorLevel( 1 )
QUIT
endif
return lRet
//----------------------------------------------------------------------------//
static function SendRel()
local oDlg, oGet101, oGet102, cEmail:=SPACE(100), cMensagem:=SPACE(300), lSave := .f.
SET _3DLOOK ON
DEFINE DIALOG oDlg RESOURCE "ErrorSys"
REDEFINE GET oGet101 VAR cEmail ID 101 OF oDlg
REDEFINE GET oGet102 VAR cMensagem MEMO ID 102 OF oDlg
REDEFINE BUTTON oBtn1 ID 1 OF oDlg ACTION (;
CheckPop3( 'pop.sao.terra.com.br', 'jscrocha', 'claudete',;
{ |o| If( SubStr( o:cStatus, 1, 3 ) == "+OK",;
SendEmailRel( cEmail, cMensagem, cHost, cReplyTo, cSubject, cMsg, lReceipt, lAuth, cUser, cPass, lPop3, cPOP3Host ), MsgStop( "Login POP3 falhou." ) ) } ), oDlg:End())
REDEFINE BUTTON oBtn2 ID 2 OF oDlg ACTION oDlg:End()
REDEFINE BUTTON oBtn3 ID 3 OF oDlg ACTION WAITRUN("NOTEPAD ERROR.LOG") NOBORDER
ACTIVATE DIALOG oDlg CENTERED
return .t.
static function SendEmailRel( cSender, cBody, cHost, cReplyTo, cSubject, cMsg, lReceipt, lAuth, cUser, cPass, lPop3, cPOP3Host )
LOCAL oInit
DEFAULT cHost := 'smtp.sao.terra.com.br' ,;
cPOP3Host := 'pop.sao.terra.com.br' ,;
cSender := 'seulogin@terra.com.br' ,;
cReplyTo := 'seulogin@terra.com.br' ,;
lReceipt := .t. ,;
lAuth := .t. ,;
lPop3 := .t. ,;
cSubject := '*** CONTROLE DE ERROS ***',;
cMsg := cBody ,;
cUser := 'seuUserName' ,;
cPass := 'suaSenha'
oInit := TSmtp():New( cHost )
oMail := TSmtp():New( cHost, , lAuth, cUser, cPass ) // [jlalin], IBTC
oMail:cReplyTo := cReplyTo
oMail:nGMT := 8 // 8 = Pacific Standard Time (GMT -08:00) - Adjust this to your own Time Zone!
oMail:nDelay := 1
*oMail:lTxtAsAttach := .F. // uncomment to force txt, log and htm files as inline as opposed to attachement
oMail:oSocket:lDebug := .T. // uncomment to create log file
oMail:oSocket:cLogFile := "smtp.log"
oMail:bConnecting := {|| oWnd:SetMsg( "Conectando a " + cHost + " (" + oMail:cIPServer + ") a aguardando resposta..." ) }
oMail:bConnected := {|| oWnd:SetMsg( "Conectado e enviando email e anexos..." ) }
oMail:SendMail( ;
'seuUserName@terra.com.br', ; // from/de
{ 'seuUserName@terra.com.br' }, ; // to/para (arreglo) - I use cSender here also because it's an "autotest". Actually you would type a different address here
cMsg,; // Body/Mensaje
cSubject,; // Subject/Asunto
{ "error.log" }, ; // Array of filenames to attach/Arreglo de nombres de archivos a agregar
{ }, ; // aCC
{ cSender }, ; // aBCC
lReceipt, ; // Return Receipt/acuse de recibo
cBody ) // msg in HTML format/mensaje en HTML
oInit:end()
Msgstop( "EMAIL enviado com sucesso!" )
return nil
// ---------------------------------------------------------------------------------- //
Static Function CheckPop3( cPOP3Host, cUser, cPass, bDone )
LOCAL oInit
// initialize sockets (or nothing will happen) - it's a quirk in GetHostByName(), not TSmtp
oInit := TSmtp():New( cPOP3Host )
oPop := TPOP3():New( cPOP3Host, , cUser, cPass )
oPop:bConnecting := {|| oWnd:SetMsg( "Connecting to " + cPOP3Host + " (" + oPop:cIPServer + ") and waiting for response..." ) }
oPop:bConnected := {|| oWnd:SetMsg( "Checking for email messages..." ) }
oPop:bDone := bDone
oPop:oSocket:lDebug := .T. // uncomment to create log file
oPop:oSocket:cLogFile := "pop3.log"
oPop:GetMail( .T. )
oInit:end()
Return Nil
//----------------------------------------------------------------------------//
static function DoBreak()
BREAK
return nil
//----------------------------------------------------------------------------//
static func ErrorMessage( e )
// start error message
local cMessage := if( empty( e:OsCode ), ;
if( e:severity > ES_WARNING, "Error ", "Warning " ),;
"(DOS Error " + NTRIM(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",;
"/" + NTRIM( 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
//----------------------------------------------------------------------------//
// returns extended info for a certain variable type
static function cGetInfo( uVal )
local cType := ValType( uVal )
do case
case cType == "C"
return '"' + cValToChar( uVal ) + '"'
case cType == "O"
return "Class: " + uVal:ClassName()
case cType == "A"
return "Len: " + Str( Len( uVal ), 4 )
otherwise
return cValToChar( uVal )
endcase
return nil
//----------------------------------------------------------------------------//
/*************
* PARA VISUALIZAR LOS ERRORES GRABADOS EN ERRORSYS
*
*
*/
FUNCTION VIEWERRORES()
LOCAL oFONT,oDLG
if !FILE("ERRORES\ERRORES.DBF")
MSGWAIT("No se ha encontrado fichero de grabación de ERRORES","Sin errores")
RETURN NIL
endif
USE "ERRORES\ERRORES.DBF" ALIAS "ERRORES" SHARED
RLOCK()
DEFINE FONT oFont NAME "Ms Sans Serif" SIZE 0, -10
DEFINE DIALOG oDlg SIZE 450, 350 TITLE "Visualización de errores del programa" FONT oFont
@ 1, 1 SAY oSay PROMPT "DATOS DEL ERROR PRODUCIDO EL DÍA "+DTOC(ERRORES->FECHA)+" HORA "+ERRORES->HORA+CRLF+CRLF+;
"Descripción del Error: "+ERRORES->DESCRIPCIO+CRLF+CRLF+;
"Desde el Usuario : "+ERRORES->USUARIO OF oDlg FONT oFont SIZE 220, 50 PIXEL UPDATE
@ 40 ,1 GET oGET VAR ERRORES->TRAZO OF oDLG MULTILINE READONLY SIZE 220, 100 PIXEL UPDATE
@ 150, 10 BUTTON oBTN1 PROMPT " |< " SIZE 20,15 PIXEL OF oDLG ACTION ( DBGOTOP(),RLOCK(),oDLG:UPDATE() )
@ 150, 35 BUTTON oBTN1 PROMPT " < " SIZE 20,15 PIXEL OF oDLG ACTION ( DBSKIP(-1),IF(BOF(),(MSGINFO("NO HAY MAS ERRORES"),DBSKIP(1)),(RLOCK(),oDLG:UPDATE())) )
@ 150, 60 BUTTON oBTN1 PROMPT " > " SIZE 20,15 PIXEL OF oDLG ACTION ( DBSKIP(1),IF(EOF(),(MSGINFO("NO HAY MAS ERRORES"),DBSKIP(-1)),(RLOCK(),oDLG:UPDATE())) )
@ 150, 85 BUTTON oBTN1 PROMPT " >| " SIZE 20,15 PIXEL OF oDLG ACTION ( DBGOBOTTOM(),RLOCK(),oDLG:UPDATE() )
@ 150, 110 BUTTON oBTN1 PROMPT "Ver pantalla" SIZE 40,15 PIXEL OF oDLG ACTION VERPANTAERR()
@ 150, 160 BUTTON oBTN1 PROMPT "Imprimir" SIZE 40,15 PIXEL OF oDLG ACTION PRINTERRORES()
ACTIVATE DIALOG oDlg CENTERED
oFont:End()
ERRORES->(DBCLOSEAREA())
RETURN NIL
FUNCTION PRINTERRORES() //IMPRESION DE ERRORES
LOCAL oPRN,oFONT
PRINTER oPRN PREVIEW
DEFINE FONT oFont NAME "COURIER NEW" SIZE 0,-10 OF oPrn
PAGE
cERROR:=ERRORES->TRAZO
nLIN:=1
FOR nLINEA=1 TO MLCOUNT(cERROR,100)
CURSORWAIT()
oPrn:CmSay(nLIN:=nLIN+.4, 1.5, MEMOLINE(cERROR,100,nLINEA),oFONT)
if nLIN>25
nLIN=1
ENDPAGE
PAGE
endif
NEXT
ENDPAGE
ENDPRINT
oFont:End()
RETURN NIL
FUNCTION VERPANTAERR()
LOCAL oIMAGE,nPOS,cImgFile
// Leemos las coordenadas de la pantalla actual y definimos la resolucion (WP)
local oWnd := WndMain()
local aCoord := GetWndRect( oWnd:hWnd ), WYRES, WXRES
ClientToScreen( oWnd:hWnd, @aCoord )
WYRES := aCoord[4]-aCoord[2]
WXRES := aCoord[3] - aCoord[1]
nPOS:=FIELDPOS("PANTALLA")
cImgFile := FieldGet( nPos )
cImgFile := if( !Empty(cImgFile), "ERRORES\" + cImgFile, "" )
if FILE(cImgFile)
DEFINE DIALOG oDlg TITLE ALLTRIM(ERRORES->DESCRIPCIO) SIZE WYRES*.9,WXRES*.9
if !Empty( cImgFile )
@ 0,0 IMAGE oIMAGE FILE cImgFile PIXEL ADJUST OF oDLG SIZE WYRES*.45,WXRES*.45
endif
ACTIVATE DIALOG oDLG on init oDlg:Center()
else
MSGINFO("No hay imagen grabada de este error","SIN IMAGEN")
endif
// Adaptación para Clipper 5.2
if File( "ERRTMP.JPG" )
DELETE FILE ERRTMP.JPG
endif
RETURN NIL
// Returns an array with the names of all the active Tasks running in Windows
//----------------------------------------------------------------------------//
function GetTasks()
local hWnd := GetWindow( GetActiveWindow(), GHW_HWNDFIRST )
local aTasks := {}
local cTask,oLdGetTasks:=.T.,hLib32:=0,RetByte:=0,BufTask
// Verify if the API exist if not it's Windows 95 or Less
// or Windows NT with SP2 or less so we will use the old technique
if ABS(hLib32:=Loadlib32("USER32.DLL")) > 32 // Can be Windows 3.11 or Lower
if substr(Getproc32(hLib32,"GetWindowModuleFileNameA",.T.,LONG,),1,4)<> CHR(0)+CHR(0)+CHR(0)+CHR(0)
oLdGetTasks:=.f.
BufTask:=space(200)
endif
Freelib32(hLib32)
endif
//
while hWnd != 0
if oLdGetTasks
#ifdef __CLIPPER__
cTask = GetModuleFileName( GetWindowWord( hWnd, GWW_HINSTANCE ) )
#else
// cTask = GetModuleFileName( GetWindowLong( hWnd, GWW_HINSTANCE ) )
cTask = GetWindowText( hWnd ) // The above does now work :-(
#endif
else
Retbyte:=GetWModFileName( hWnd, BufTask, 200 )
cTask:=left(BufTask,Retbyte)
endif
if ! Empty(cTask)
if AScan( aTasks, cTask ) == 0
AAdd( aTasks, cTask )
endif
endif
hWnd = GetWindow( hWnd, GHW_HWNDNEXT )
end
return aTasks
//----------------------------------------------------------------------------//
DLL32 FUNCTION GetWModFileName( hWnd AS LONG, cBuf AS LPSTR, nLong AS LONG ) ;
AS LONG PASCAL FROM "GetWindowModuleFileNameA" LIB "USER32.DLL"
//------------------------------------------------------------------------
#include "struct.ch"
#include "DLL.CH"
#define HKEY_CURRENT_USER 2147483649 // 0x80000001
#define HKEY_LOCAL_MACHINE 2147483650 // 0x80000002
#DEFINE MEM_TotalPhys 1
#DEFINE MEM_AvailPhys 2
#DEFINE MEM_TotalPageFile 3
#DEFINE MEM_AvailPageFile 4
#DEFINE MEM_TotalVirtual 5
#DEFINE MEM_AvailVirtual 6
CLASS TSystemInfo
DATA nOsVer, nMajor, nMinor, nBuild, nPlatform, cSP
DATA wSerPackM, wSerPacki, wSteMask, wProdType, wRes
DATA TSIVersion
METHOD New( lTest )
METHOD WinVer()
METHOD VerNum() INLINE LTrim( Str( ::nMajor ) ) + "." +;
LTrim( Str( ::nMinor ) ) + "." +;
LTrim( Str( ::nBuild ) ) +;
RTrim( " " + ::cSP ) // added by LKM
METHOD WhichNT()
METHOD TimeZone()
METHOD DateSystemBios()
METHOD NameSystemBios()
METHOD DateVideoBios()
METHOD NameVideoBios()
METHOD ComputerName()
METHOD IEStartPage()
METHOD IEVersion()
METHOD DTWallpaper()
METHOD DirectxVersion()
METHOD Ass4Ext(cExt) // Associated programme for this extention
METHOD BootDir()
METHOD GetColors()
METHOD SpeedCPU(nCPU)
METHOD CPU() INLINE GetCPU()
METHOD IsDualCPU() INLINE ::SpeedCPU(2)>0
METHOD CPUVendor(nCPU)
METHOD CPUIdentifier(nCPU)
METHOD IsWin95() INLINE ::nPlatform<2 .AND. ::nMajor=4 .AND. ::nMinor=0 .AND. ::nBuild=950
METHOD IsWin95SP1() INLINE ::nPlatform<2 .AND. ::nMajor=4 .AND. ::nMinor=0 .AND. ::nBuild<=1080
METHOD IsWin95OSR2() INLINE ::nPlatform<2 .AND. ::nMajor=4 .AND. ::nMinor<10 .AND. ::nBuild>1080
METHOD IsWin98() INLINE ::nPlatform<2 .AND. ::nMajor=4 .AND. ::nMinor=10 .AND. ::nBuild=1998
METHOD IsWin98SP1() INLINE ::nPlatform<2 .AND. ::nMajor=4 .AND. ::nMinor=10 .AND. ::nBuild>1998 .AND. ::nBuild<2183
METHOD IsWin98SE() INLINE ::nPlatform<2 .AND. ::nMajor=4 .AND. ::nMinor=10 .AND. ::nBuild>2183
METHOD IsWinME() INLINE ::nPlatform<2 .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 lWin2000
METHOD IsWinXP() INLINE ::nPlatform=2 .AND. ::nMajor=5 .AND. ::nMinor=1
METHOD ServicePack() INLINE If(lWin2000,"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 lWin2000 .AND. Upper(::WhichNT())="WINNT"
METHOD IsWin2000Server() INLINE lWin2000 .AND. ( Upper(::WhichNT())="SERVERNT" .OR. Upper(::WhichNT())="LANMANNT")
METHOD Memory(n)
ENDCLASS
//-----------------------------------
METHOD New( lTest ) CLASS TSystemInfo
LOCAL buffer, sInfo
::TSIVersion:="1.04"
if Valtype( lTest )#"L"
lTest:=.f.
endif
lWin2000:=IsWin2K()
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 lWin2000
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())
buffer:=sInfo:cBuffer
if GetVerExA(@buffer) <> 1
MsgInfo("Error on Calling GetVersionExA")
return self
endif
sInfo:cBuffer:=buffer
::nOSVer :=nLoWord(sInfo:nLOSVer)
::nMajor :=nLoWord(sInfo:nLMajor)
::nMinor :=nLoWord(sInfo:nLMinor)
::nBuild :=nLoWord(sInfo:nLBuild)
::nPlatform:=nLoWord(sInfo:nLPlatform)
::cSP :=Alltrim(psz(sInfo:cLSP))
if lWin2000
::wSerPackM:=nLoWord(sInfo:wLSerPackM)
::wSerPacki:=nLoWord(sInfo:wLSerPacki)
::wSteMask :=nLoWord(sInfo:wLSteMask)
::wProdType:=sInfo:wLProdType
::wRes :=sInfo:wLRes
endif
if lTest
MsgInfo("nOsVers = " +LTrim(Str(::nOsVer)) +CRLF+;
"nMajor = " +LTrim(Str(::nMajor)) +CRLF+;
"nMinor = " +LTrim(Str(::nMinor)) +CRLF+;
"nBuild = " +LTrim(Str(::nBuild)) +CRLF+;
"sPlatform = " +LTrim(Str(::nPlatform)) +CRLF+;
"cSP = " + AllTrim(::cSP))
if lWin2000
MsgInfo("wSerPackM = " +LTrim(Str(::wSerPackM))+CRLF+;
"wSerPacki = " +LTrim(Str(::wSerPacki))+CRLF+;
"wSteMask = " +LTrim(Str(::wSteMask ))+CRLF+;
"wProdType = " +LTrim(Str(::wProdType))+CRLF+;
"wRes = " +LTrim(Str(::wRes ))+CRLF,"Windows2000 Info")
endif
endif
return Self
//--------------------------------------------------------------------
Function IsWin2K()
LOCAL sInfo, buffer
STRUCT sInfo
MEMBER OsVer AS DWORD // Size of the structure
MEMBER Major AS DWORD // Major windows Version
MEMBER Minor AS DWORD // Minor Windows Version
MEMBER Build AS DWORD // Build Number
MEMBER Platform AS DWORD // Wich Platform
MEMBER SP AS STRING LEN 128 // Service Pack (Nt/2000)
ENDSTRUCT
sInfo:Setmember(1,sInfo:Sizeof())
buffer:=sInfo:cBuffer
if GetVerExA(@buffer) <> 1
MsgInfo("Error on Calling GetVersionExA")
return .f.
endif
sInfo:cBuffer:=buffer
RETURN (sInfo:Platform=2 .AND. sInfo:Major=5 .AND. sInfo:Minor=0)
//--------------------------------------------------------------------
METHOD WinVer( ) CLASS TSystemInfo
LOCAL cVersion:=""
DO CASE
CASE ::IsWin95() ; cVersion:="Windows 95"
CASE ::IsWin95SP1() ; cVersion:="Windows 95 Service pack 1"
CASE ::IsWin95OSR2() ; cVersion:="Windows 95 OSR2"
CASE ::IsWin98() ; cVersion:="Windows 98"
CASE ::IsWin98SP1() ; cVersion:="Windows 98 Service pack 1"
CASE ::IsWin98SE() ; cVersion:="Windows 98 Second Edition"
CASE ::IsWinME() ; cVersion:="Windows ME"
CASE ::IsWinNT31() ; cVersion:="Windows NT 3.1"
CASE ::IsWinNT35() ; cVersion:="Windows NT 3.5"
CASE ::IsWinNT351() ; cVersion:="Windows NT 3.51"
CASE ::IsWinNT4() ; cVersion:="Windows NT 4"
CASE ::IsWin2000() ; cVersion:="Windows 2000 "+If(::IsWin2000Prof,"Professional","Server")+" "+AllTrim(::cSP)+" build "+LTrim(Str(::nBuild))
CASE ::IsWinXP() ; cVersion:="Windows XP build "+LTrim(Str(::nBuild))+" "+::cSP
OTHER ; cVersion:="Unknown Windows version"
ENDCASE
RETURN cVersion
//--------------------------------------------------------------------
METHOD WhichNT() CLASS TSystemInfo
LOCAL oReg, uVar
oReg := TReg32():New(HKEY_LOCAL_MACHINE,"System\CurrentControlSet\Control\ProductOptions",.f.)
uVar := oReg:Get("ProductType","")
oReg:Close()
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 := 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 := 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 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 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 := 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 := 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 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 Memory(n) CLASS TSystemInfo
LOCAL nRetu
#ifdef __HARBOUR__
#pragma BEGINDUMP
#include "windows.h"
#pragma ENDDUMP
nRetu := HB_INLINE( n )
{
MEMORYSTATUS mst;
long n = hb_parnl(1);
mst.dwLength = sizeof( MEMORYSTATUS );
GlobalMemoryStatus( &mst );
switch( n )
{
case 1: hb_retnl( mst.dwTotalPhys / (1024*1024) ) ; break;
case 2: hb_retnl( mst.dwAvailPhys / (1024*1024) ) ; break;
case 3: hb_retnl( mst.dwTotalPageFile / (1024*1024) ) ; break;
case 4: hb_retnl( mst.dwAvailPageFile / (1024*1024) ) ; break;
case 5: hb_retnl( mst.dwTotalVirtual / (1024*1024) ) ; break;
case 6: hb_retnl( mst.dwAvailVirtual / (1024*1024) ) ; break;
default: hb_retnl( 0 ) ;
}
}
#else
LOCAL oMemory
STRUCT oMemory
MEMBER m1 AS LONG // nSize
MEMBER m2 AS LONG // Memory Load
MEMBER m3 AS LONG // Total Physical
MEMBER m4 AS LONG // Available Physical
MEMBER m5 AS LONG // Total Page File
MEMBER m6 AS LONG // Available Page File
MEMBER m7 AS LONG // Total Virtual
MEMBER m8 AS LONG // Available Virtual
ENDSTRUCT
oMemory:m1 = oMemory:SizeOf()
MemStat( oMemory:cBuffer )
DO CASE
CASE n=1 ; nRetu:=Round( oMemory:m3 / (1024*1024) ,0 )
CASE n=2 ; nRetu:=Round( oMemory:m4 / (1024*1024) ,0 )
CASE n=3 ; nRetu:=Round( oMemory:m5 / (1024*1024) ,0 )
CASE n=4 ; nRetu:=Round( oMemory:m6 / (1024*1024) ,0 )
CASE n=5 ; nRetu:=Round( oMemory:m7 / (1024*1024) ,0 )
CASE n=6 ; nRetu:=Round( oMemory:m8 / (1024*1024) ,0 )
OTHERWISE; nRetu:=0
ENDCASE
#endif
RETURN nRetu
#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))
//--------------------------------------------------------------------
DLL32 FUNCTION GetVerExA( @lpVersionInformation AS LPSTR );
AS LONG PASCAL FROM "GetVersionExA" LIB "KERNEL32.DLL"
STATIC Function psz( c ) ; RETURN substr( c, 1, At( Chr(0), c ) - 1 )
STATIC Function Remove0( c ) ; RETURN StrTran( c, Chr(0), " " )
#ifdef __HARBOUR__
#pragma BEGINDUMP
static void hb_retnl( LONG l )
{
hb_itemPutNL( &hb_stack.Return, l );
}
#pragma ENDDUMP
#endif
//--------------------------------------------------------------------
// Reemplazo a SalvaraBMP
// Original de Williams Pacheco 2003 + Bingen 2003
//--------------------------------------------------------------------
function SalvarBmp( hDib, cBmpFile, cFormat )
local cRetVal := "ERRORES\" + cBmpFile + ".BMP"
CURSORWAIT()
DibWrite( cRetVal, hDib )
CURSORWAIT()
IF UPPER(cFormat) = "JPG" .and. File( "NCONVERT.EXE" )
WaitRun( "nconvert -out jpeg " + " -D " + ".\ERRORES\" + cBmpFile +".BMP" , 0 )
ENDIF
CURSORWAIT()
return IF(UPPER(cFormat) = "JPG",cFileName( STRTRAN(cRetVal,".BMP",".JPG" )),cFileName( cRetVal ))
O código deve ser agregado ao seu .RMK para ser gerado o .OBJ e o .OBJ ligado ao seu .LNK para fazer parte do seu sistema.
O .RC deve ser acrescentado às diálogos de seu sistema para ser ligada no momento da compilação.
Ficou Show de bola. Só não garanto que o envio da mensagem de erro via email saia uma beleza mas a idéia é boa.
O intuito é o usuario ser informado de forma mais profissional sobre uma ocorrencia de erro, ser acalmado e ter o arquivo enviado ao email do suporte ou desenvolvimento.
@braços :?)