Code: Select all
// 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
// ------------------------------------------------------------------
// Modification and Enhancement by Stefan Haupt, 2007/2008
// - the errorhandler is now independent of any rc-file,
// all dialogs are now coded from source
// - all dialogs now have a modern design (in my opinion)
// the color can be change with #define 'COLOR_DIALOG'
// predefined are COLOR_XP, COLOR_VISTA and COLOR_ALERT
// - SaveBmp() was changed to get rid of the program "nconvert"
// now it uses a freeimage function to save the bitmap as png-file
// - email configuration is read from ini-file
// - function CheckPop3() is no longer needed (still in this file)
// - Sendmail() was changed to read the ini-file
// - ShowerrPic() was corrected to show the whole bitmap
// - all textstrings were translated into german (sorry)
// ------------------------------------------------------------------
// Modification and Enhancement by Gale Ford, 2011
// - Added #define for all text and buttons that were still hardcoded.
// - English and German should be correct for all text.
// - Changed screen image creation to before the error dialog is shown
// so it could be added to the email as an attachment.
// - FISaveImg() replaced with with built in
// Fivewin function FIConvertImageFile()
// - Changed Error dialog to use Red
// and the View dialog to use Green.
// - Added 2 fields to errors.dbf,
// User = gete('USERNAME') and WholeName = gete('WHOLE_NAME')
// If you alread have an errors.dbf then it gets renamed to errors.sav
// so the new errors.dbf can be created.
// - Added #define emailDOMAIN so that "user", "from", and other can be
// put together with emailDOMAIN to better automate email notification.
// TODO:
// translate the #defines to support more languages
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
#define SS_SUNKEN 4096
#define NTRIM(n) ( LTrim( Str( n ) ) )
#define DLG_TITLE "FiveWin for xHarbour"
#command QUIT => ( PostQuitMessage( 0 ), __Quit() )
#define sysERRORSDIR "ERRORS\"
//----------------------------------------------------------------------------//
#define E_INIFILE ".\Email.ini"
#define E_USER 1
#define E_LOGIN 2
#define E_PASS 3
#define E_POP3 4
#define E_SMTP 5
#define E_CONNECT 6
#define E_SAVE 7
#define E_DELETE 8
#define E_FROM 9
#define E_TO 10
// Dialog colors
#define COLOR_XP {nRGB( 3, 56, 147 ),nRGB( 89, 135, 214 )} //RGB( 0, 0, 128)
#define COLOR_VISTA {nRGB( 46, 139, 87) ,nRGB( 0, 250, 154)} //RGB( 0, 139, 69)
#define COLOR_ALERT {nRGB( 178, 34, 34 ), nRGB (255, 116, 132 ) }
//#define COLOR_ALERT {nRGB( 178, 34, 34 ), nRGB (255, 228, 255 ) }
#define COLOR_BAR COLOR_VISTA
#define COLOR_TEXT CLR_WHITE
//#define _GERMAN
//#define _SPANISH
#define _ENGLISH
//#define _ITALIAN
//#define _PORTUG
#ifdef _GERMAN
#define dlgPROG "Programm: "
#define dlgTITLE "Programmfehler"
#define errHEADER "Fehlerbeschreibung"
#define errDESC " Beschreibung : "
#define errPROGPATH " Programmpfad : "
#define errPROGSIZE " Dateigröße : "
#define errMAXFILES " Max. Dateien : "
#define errTIME " Laufzeit : "
#define errOCCUR " Fehlerzeitpunkt: "
#define errNETNAME " Computername : "
#define errUSER " Anwender : "
#define errDETAIL "detaillierte Beschreibung des Fehlers"
#define errSTACKLIST "Stack-Liste"
#define errSTACKCALL " Aufruf von "
#define errTASKS "Liste der Windowstasks: "
#define errVARLIST "Liste aller Variablen"
#define errVARIABLE " Name Typ Wert"
#define errRDD "Datenbanktreiber"
#define errOPENDBF "Geöffnete Datenbanken"
#define errINDEX "Indexdateien "
#define errRELATION "Datenbankrelationen"
#define dlgTEXT1 "Leider ist ein Fehler aufgetreten."+CRLF+;
"Bitte informieren Sie den Hersteller der Software über diesen Fehler und "+CRLF+;
"wie er aufgetreten ist."+CRLF+;
"Alle Angaben werden vertraulich behandelt."
#define dlgTEXT2 "Fehlerbeschreibung:"
#define BTN_Header "Fehlerinformation"
#define BTN_View "Fehlerlog im Editor ansehen"
#define BTN_Retry "Erneut versuchen"
#define BTN_Default "Standardwerte"
#define BTN_Send1 "Fehlerbericht senden"
#define BTN_Send2 "Fehlerbericht"
#define BTN_Send3 "Fehlerbericht gesendet"
#define BTN_End "nicht senden / Beenden"
#define BTN_Help "Hilfe"
#define emailADDRESS "info@ibbsh.de"
#define emailKEY "3jfbt72"
#define emailDOMAIN "ibbsh.de"
#define emailALERT1 "Email-Einstellungen fehlerhaft"
#define emailALERT2 "Email versenden"
#define emailCONNECTING1 "Anschließen an "
#define emailCONNECTING2 "und wartet auf Antwort..."
#define emailCONNECTED "Email wird versandt..."
#define emailCONNECTEDPOP "Suchen nach E-Mails ..."
#define viewALERT1 "Die Fehlerprotokolldatei fehlt"
#define viewALERT2 "Fehlerprotokolles"
#define viewERRORTitle "Fehlerprotokolle ansehen"
#define viewERROR1 "Datum des Fehlers "
#define viewERROR2 " Uhrzeit "
#define viewERROR3 "Fehlerbeschreibung"
#define viewERROR4 "Benutzer/PC "
#define viewERROR5 "Fehler "
#define viewBTNImg "Fehlergrafik"
#define viewBTNPrint "Drucken"
#define viewBTNClose "Schließen"
#define showPICTitle "Fehlergrafik"
#define showPICERROR1 "Keine Grafik vorhanden"
#define showPICERROR2 "Fehlergrafik"
#endif
#ifdef _SPANISH
#endif
#ifdef _ENGLISH
#define dlgPROG "Program: "
#define dlgTITLE "Application error"
#define errHEADER "Errordescription"
#define errDESC " Description : "
#define errPROGPATH " App-Path : "
#define errPROGSIZE " Filesize : "
#define errMAXFILES " Max. files : "
#define errTIME " Time from start: "
#define errOCCUR " Occurance : "
#define errNETNAME " Computername : "
#define errUSER " User : "
#define errDETAIL "detailled error description"
#define errSTACKLIST "Stack-List"
#define errSTACKCALL " called by "
#define errTASKS "running tasks: "
#define errVARLIST "Varlist"
#define errVARIABLE " Name Type Value"
#define errRDD "RDD"
#define errOPENDBF "Open dbf´s"
#define errINDEX "Index files "
#define errRELATION "Relations"
#define sysHEADER "Systeminformation"
#define sysWINDOWS
#define sysVERSION
#define dlgTEXT1 "Please contact your dealer or computer support department"+CRLF+;
"about this error and the circumstances it happened."+CRLF+CRLF+;
[Email error report by clicking "Send errorlog" button]
#define dlgTEXT2 "Error Description:"
#define BTN_Header "An Error Has Occurred"
#define BTN_View "View errorlog"
#define BTN_Retry "Retry"
#define BTN_Default "Default"
#define BTN_Send1 "Send errorlog"
#define BTN_Send2 "Errorlog"
#define BTN_Send3 "Errorlog sent"
#define BTN_End "do not send / end"
#define BTN_Help "Help"
#define emailDOMAIN "usersdomain.com"
#define emailADDRESS "help.desk@helpdomain.com"
#define emailKEY "3jfbt72"
#define emailALERT1 "Email settings are incorrect"
#define emailALERT2 "Email Settings"
#define emailCONNECTING1 "Connecting to "
#define emailCONNECTING2 "and waiting for response..."
#define emailCONNECTED "Sending Email..."
#define emailCONNECTEDPOP "Checking for email messages..."
#define viewALERT1 "The error log file is missing"
#define viewALERT2 "error Log"
#define viewERRORTitle "View Error Logs"
#define viewERROR1 "Date of the error "
#define viewERROR2 " time "
#define viewERROR3 "Error description "
#define viewERROR4 "User/PC "
#define viewERROR5 "Error Image "
#define viewBTNImg "View Image"
#define viewBTNPrint "Print"
#define viewBTNClose "Close"
#define showPICTitle "Graphic Error"
#define showPICERROR1 "No Graphics Available"
#define showPICERROR2 "Graphic Error"
#endif
#ifdef _ITALIAN
#endif
#ifdef _PORTUG
#endif
external _fwGenError // Link FiveWin generic Error Objects Generator
/******************************************************
* 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, oFont, oFont1
//local lRet // if lRet == nil -> default action: QUIT
local nArea := select()
local n, j
local oSay, oSay1, oGet//, cTxt1, cTxt2, hLogo
local nButtons := 1, hLogo
local cErrorLog := "", cParam := "", cVariables := "", cStack := ""
LOCAL aStack := {}, cMessage := "", cTxt1 := "", cTxt2 := ""
local aVersions := {}
local aTasks := {}
local aRDDs, nTarget, uValue
local oOldError
local cRelation
local lIsWinNT := IsWinNT()
// local oSystemInfo
local oWnd := WndMain()
local cTitle := IIF (!Empty(oWnd),"Programm: "+oWnd:cTITLE, dlgTITLE)
local hBmp, hDib, cImgFile
local aScreens:=array(0), nScreen, nScreens:=30 //max. 30 Screenshots
local cUser := WNetGetUser ()
local oBtn1, oBtn2, oBtn3, oBtn4, oBtn5
static lRet
// Definimos cUser por si acaso el sistema no maneja este valor (WP)
cUser := if( ValType( 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
if Left( ProcName( 7 ), 10 ) == "ERRORDIALO"
SET RESOURCES TO
ErrorLevel( 1 )
QUIT
endif
ErrorBlock( {|e| MsgStop( ErrorMessage(e) + " from Errorsys, line:" + ;
Str( ProcLine( 1 ), 3 ) ), __quit() } )
// aTasks := GetTasks()
// aVersions := GetVersion()
/* DESCRIPCIÓN DEL ERROR */
cErrorLog += errHEADER + CRLF
cErrorLog += cTitle + CRLF
cErrorLog += "-----------------------------------------" + CRLF
cErrorLog += errPROGPATH + GetModuleFileName( GetInstance() ) + CRLF
cErrorLog += errPROGSIZE + Transform( FSize( GetModuleFileName( GetInstance() ) ), "9,999,999 bytes" ) + CRLF
cErrorLog += errMAXFILES + Str( SetHandleCount(), 3 ) + CRLF
cErrorlog += errTIME + TimeFromStart () + CRLF
cErrorLog += errOCCUR + DToC( Date() ) + ", " + Time() + CRLF
cErrorLog += errNETNAME + NETNAME(.f.) + CRLF
cErrorLog += errUSER + cUser + CRLF + CRLF
// Error object analysis
cMessage = errDETAIL + CRLF+;
Replicate ("-",Len(errDETAIL)) + CRLF+;
" "+ErrorMessage( e ) + CRLF
cErrorLog += cMessage
if ValType( e:Args ) == "A"
cErrorLog += " Parameter :" + CRLF
for n = 1 to Len( e:Args )
cErrorLog += " [" + Str( n, 4 ) + "] = " + ValType( e:Args[ n ] ) + ;
" " + cValToChar( e:Args[ n ] ) + CRLF
cParam += " [" + Str( n, 4 ) + "] = " + ValType( e:Args[ n ] ) + ;
" " + cValToChar( e:Args[ n ] ) + CRLF
next
endif
cErrorlog += CRLF + errSTACKLIST + CRLF
cErrorlog += Replicate ("-",Len(errSTACKLIST)) + CRLF
n := 2 // we don't disscard any info again !
while ( n < 74 )
if ! Empty(ProcName( n ) )
AAdd( aStack, errSTACKCALL + Trim( ProcName( n ) ) + ;
"(" + NTRIM( ProcLine( n ) ) + ")" )
cStack += ATail( aStack ) + CRLF
endif
n++
end
cErrorlog += cStack
cErrorLog += " CPU type: " + GetCPU() + " " + ;
AllTrim( Str( GetCPUSpeed() ) ) + " Mhz" + CRLF
cErrorLog += " Hardware memory: " + ;
cValToChar( Int( nExtMem() / ( 1024 * 1024 ) ) + 1 ) + ;
" MB" + CRLF + CRLF
cErrorLog += " Free System resources: " + AllTrim( Str( GetFreeSystemResources( 0 ) ) ) + " %" + CRLF + ;
" GDI resources: " + AllTrim( Str( GetFreeSystemResources( 1 ) ) ) + " %" + CRLF + ;
" User resources: " + AllTrim( Str( GetFreeSystemResources( 2 ) ) ) + " %" + CRLF + CRLF
cErrorLog += " Compiler version: " + Version() + CRLF
aVersions := GetVersion()
cErrorLog += " Windows version: " + ;
AllTrim( Str( aVersions[ 1 ] ) ) + "." + ;
AllTrim( Str( aVersions[ 2 ] ) ) + ", Build " + ;
AllTrim( Str( aVersions[ 3 ] ) ) + ;
" " + aVersions[ 5 ] + CRLF + CRLF
cErrorLog+=CRLF
cErrorLog+=CRLF+ errTASKS + Str( Len (aTasks), 3 )
cErrorLog+=CRLF+ Replicate ("-",Len(errTASKS))
cErrorLog+=CRLF
aTasks = GetTasks()
for n = 1 to Len( aTasks )
cErrorLog += " " + Str( n, 3 ) + " " + aTasks[ n ] + CRLF
next
// 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
cVariables += CRLF + errVARLIST + CRLF + ;
Replicate ("-",Len(errVARLIST)) + CRLF
cVariables += errVARIABLE + CRLF
cVariables += Replicate ("-",Len(errVARIABLE)) + CRLF
n := 2 // we don't disscard any info again !
while ( n < 74 )
if ! Empty( ProcName( n ) ) .AND. ProcName( n )<>"ERRORDIALO"
cVariables += " " + Trim( ProcName( n ) ) + CRLF
for j = 1 to ParamCount( n )
cVariables += " Param " + Str( j, 3 ) + ": " + ;
ValType( GetParam( n, j ) ) + ;
" " + cGetInfo( GetParam( n, j ) ) + CRLF
next
for j = 1 to LocalCount( n )
cVariables += " Local " + Str( j, 3 ) + ": " + ;
ValType( GetLocal( n, j ) ) + ;
" " + cGetInfo( GetLocal( n, j ) ) + CRLF
next
endif
n++
end
cErrorLog += cVariables
cErrorLog += CRLF + errRDD + CRLF + ;
Replicate ("-",Len(errRDD)) + CRLF
aRDDs = RddList( 1 )
for n = 1 to Len( aRDDs )
cErrorLog += " " + aRDDs[ n ] + CRLF
next
cErrorLog += CRLF + errOPENDBF + CRLF + ;
Replicate ("-",Len(errOPENDBF)) + 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
if ( Alias( n ) )->( RddName() ) != "ARRAYRDD"
cErrorLog += errINDEX + 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 + errRELATION + CRLF+;
Replicate ("-",Len(errRELATION))
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 // ( Alias( n ) )->( RddName() ) != "ARRAYRDD"
endif // !Empty( Alias(n))
next
n = 1
cErrorLog += CRLF + "internal classes" + CRLF
cErrorLog += "----------------" + CRLF
// while ! Empty( __ClassName( n ) )
// cErrorLog += " " + Str( n, 3 ) + " " + __ClassName( n++ ) + CRLF
// end
#ifndef __XHARBOUR__
while ! Empty( __ClassName( n ) )
cErrorLog += " " + Str( n, 3 ) + " " + __ClassName( n++ ) + CRLF
end
#else
while n <= __ClsCntClasses()
cErrorLog += " " + Str( n, 3 ) + " " + __ClassName( n++ ) + CRLF
end
#endif
cErrorLog += CRLF + "Memory Analysis" + CRLF
cErrorLog += "===============" + CRLF
cErrorLog += " " + LTrim( Str( nStatics() ) ) + " Static variables" + ;
CRLF + CRLF
cErrorLog += " Dynamic memory consume:" + CRLF
cErrorLog += " Actual Value: " + Str( MemUsed() ) + " bytes" + CRLF
cErrorLog += " Highest Value: " + Str( MemMax() ) + " bytes" + CRLF
/* GRABAR FICHERO DEL ERROR*/
// BEGIN SEQUENCE
// oOldError = ErrorBlock( { || DoBreak() } )
MemoWrit( "Error.log", cErrorLog )
// END SEQUENCE
// ErrorBlock( oOldError )
cTxt1 := dlgTEXT1
cTxt2 := dlgTEXT2+CRLF+ErrorMessage( e )+CRLF+cParam+CRLF+cStack
/*
bDone := nil //{|| oWnd:SetMsg( "Email wird versandt..." ) }
*/
if lRet == nil .or. ( !LWRunning() .and. lRet )
BEGIN SEQUENCE
oOldError = ErrorBlock( { || DoBreak() } )
/* CONTROL PERSONALIZADO DE ERRORES */
if !lIsDir( "ERRORS" ) //CREAR CARPETA DE ERRORES DEL PROGRAMA
lMkDir( "ERRORS" )
endif
// Check if new fields User and WholeName in this version
// If not then rename it so new version can be created
IF FILE(sysERRORSDIR+"ERRORS.DBF")
select 0
USE ( sysERRORSDIR+"ERRORS.DBF" ) SHARED
IF type("errors->user") != "C"
use
frename( sysERRORSDIR+"ERRORS.DBF", sysERRORSDIR+"ERRORS.SAV" )
ELSE
use
ENDIF
ENDIF
IF !FILE(sysERRORSDIR+"ERRORS.DBF")
DbCreate(sysERRORSDIR+"ERRORS.DBF",;
{{"Comp","C",11,0},{"Date","D",8,0},;
{"Time","C",8,0},{"Error","C",76,0},;
{"User","C",15,0},{"WholeName","C",76,0},;
{"Descript","M",10,0},{"Picture","C",30,0} })
ENDIF
SET PRINTER OFF
SET CONSOLE ON
select 0
USE ( sysERRORSDIR+"ERRORS.DBF" ) SHARED
APPEND BLANK
REPLACE Comp WITH NETNAME()
REPLACE Date WITH DATE()
REPLACE Time WITH TIME()
REPLACE Error WITH STRTRAN(ErrorMessage( e ),CRLF," ")
REPLACE Descript WITH cERRORLOG
REPLACE User WITH gete('USERNAME')
REPLACE WholeName WITH gete('WHOLE_NAME')
hBmp := WndBitmap( oWnd:hWnd )
hDib := DibFromBitmap( hBmp )
cImgFile := "Err" + StrZero( RecNo(), 5 )
aScreens:=DIRECTORY(sysERRORSDIR+"*.png")
aScreens:=ASORT(aScreens,,, { |x, y| x[1] < y[1] })
FOR nScreen:=1 TO LEN(aScreens)-nScreens
DELETE FILE (sysERRORSDIR+aScreens[nScreen,1]) // delete all files more than 30
NEXT
cImgFile := SaveBmp( hDib, cImgFile, "png" )
REPLACE Picture WITH cImgFile
COMMIT
END SEQUENCE
ErrorBlock( oOldError )
endif
/* Errordialog */
DEFINE FONT oFont NAME "Ms Sans Serif" SIZE 0, -10
DEFINE FONT oFont1 NAME "Arial" SIZE 0, -18 BOLD
DEFINE DIALOG oDlg SIZE 420,322 TITLE cTitle PIXEL TRANSPARENT
@ 2,2 SAY oSay PROMPT BTN_Header OF oDlg SIZE 211,27 ;
FONT oFont1 PIXEL
@ 30,2 SAY oSay1 PROMPT cTxt1 OF oDlg SIZE 207,32 PIXEL
oSay1:nStyle := nOR( oSay:nStyle, SS_SUNKEN )
@ 65,2 GET oGet VAR cTxt2 OF oDlg MEMO SIZE 206,50 PIXEL
oGet:SetPos(0,0)
@ 122,2 BUTTON oBtn3 PROMPT BTN_View SIZE 80,10 ;
ACTION WAITRUN("NOTEPAD ERROR.LOG");
PIXEL
@ 122,85 BUTTON oBtn4 PROMPT BTN_Retry SIZE 50,10 ;
ACTION (lRet := .t., oDlg:End() ) ;
PIXEL
@ 122,138 BUTTON oBtn5 PROMPT BTN_Default SIZE 50,10;
ACTION (lRet := .f., oDlg:End() );
PIXEL
@ 136,2 BUTTON oBtn1 PROMPT BTN_Send1 OF oDlg SIZE 80,10 ;
ACTION (CursorWait (),;
SendEmail(BTN_Send2, cErrorlog,, oDlg, sysERRORSDIR+cImgFile ),;
CursorArrow (),;
oDlg:oMsgbar:cMsgDef := BTN_Send3, oDlg:oMsgbar:Refresh() ) ;
PIXEL
// CheckPop3(cPop3Host, cUser, cPass, bDone, oWnd ) PIXEL
// {|o| If( SubStr( o:cStatus, 1, 3 ) == "+OK",MsgInfo("OK"),MsgInfo("Fehler") )},oWnd );
@ 136,85 BUTTON oBtn2 PROMPT BTN_End OF oDlg SIZE 80,10 ;
ACTION oDlg:End() DEFAULT PIXEL
@ 136,168 BUTTON BTN_Help OF oDlg SIZE 30,10 PIXEL ACTION MsgInfo (BTN_Help)
//IF !e:CanRetry; oBtn4:Disable (); ENDIF
//IF !e:CanDefault; oBtn5:Disable (); ENDIF
ACTIVATE DIALOG oDlg CENTERED ;
ON INIT ( oDlg:oMsgBar := TMsgBar():New(oDlg, BTN_Header,.F.,.F.,.F.,.F.,,,,),;
iif(e:CanRetry,oBtn4:Enable(),oBtn4:Disable()),;
iif(e:CanDefault,oBtn5:Enable(),oBtn5:Disable()) );
ON PAINT (oBtn2:Setfocus(), Degrade (oDlg:hDC, {1,1,57,422},COLOR_ALERT[2],COLOR_ALERT[1] ) );
VALID (oFont:End(), oFont1:End(),.t.)
/* CERRAR MDICHILD FICHEROS Y RECURSOS Y SALIR */
// if TYPE( "oMainWnd" ) = "O"
// oWnd:CLOSEALL()
// endif
if alias() = 'ERRORS'
use
endif
dbselectarea( nArea )
if lRet == nil .or. ( !LWRunning() .and. lRet )
// DBCLOSEALL()
SET RESOURCES TO
ErrorLevel( 1 )
QUIT
endif
return lRet
//-------------------------------------------------------------------------------
static function SendEmail (cSubject, cBody, cMsg, oWnd, cImgFile)
LOCAL oInit, oMail, aSet, i, lOk := .f.
LOCAL lReceipt := .f.
LOCAL lAuth := .f.
LOCAL cFrom
LOCAL aAttach
DEFAULT cMsg := nil //HTML Email
aSet := ReadIni ()
cFrom := TRIM (aSet[E_USER])+" <"+TRIM (aSet[E_FROM])+">"
FOR i := 1 TO Len (aSet)
lOk := !Empty (aSet[i])
//? aSet[i]
NEXT
IF ! lOk
MsgAlert ( emailALERT1, emailALERT2)
RETURN (nil)
ENDIF
FErase ("Smtp.log") // delete old logfile
if file( cImgFile )
aAttach := { "error.log", cImgFile }
else
aAttach := { "error.log" }
endif
oInit := TSmtp():New( aSet [E_SMTP] )
oMail := TSmtp():New( aSet [E_SMTP], , lAuth, aSet [E_LOGIN], aSet [E_PASS] ) // [jlalin], IBTC
oMail:cReplyTo := aSet[E_FROM] //aSet [E_REPLYTO] //cReplyTo
oMail:nGMT := 1 // 8 = Pacific Standard Time (GMT -08:00) - Adjust this to your own Time Zone!
oMail:lTxtAsAttach := .F. // uncomment to force txt, log and htm files as inline as opposed to attachement
oMail:nDelay := 2
oMail:oSocket:lDebug := .T. // uncomment to create log file
oMail:oSocket:cLogFile := "smtp.log"
oMail:bConnecting := {||MsgRun( emailCONNECTING1 + aSet [E_SMTP] + " (" + oMail:cIPServer + ") "+emailCONNECTING2) }
oMail:bConnected := {||MsgRun ( emailCONNECTED ) }
oMail:SendMail( ;
cFrom, ; // from/de
{ aSet[E_TO] }, ; // to/para (arreglo) - I use cSender here also because it's an "autotest". Actually you would type a different address here
cBody,; // Body/Mensaje
cSubject,; // Subject/Asunto
aAttach, ; // Array of filenames to attach/Arreglo de nombres de archivos a agregar
{ }, ; // aCC
{ }, ; // aBCC
lReceipt, ; // Return Receipt/acuse de recibo
cMsg ) // msg in HTML format/mensaje en HTML
oInit:end()
return (nil)
// ---------------------------------------------------------------------------------- //
Static Function CheckPop3( cPOP3Host, cUser, cPass, bxDone, oWnd )
LOCAL lRet
LOCAL oInit, oPop
LOCAL bDone := {|o| IIF ( SubStr( o:cStatus, 1, 3 ) == "+OK", MsgInfo("OK"),MsgInfo ("Fehler")) }
// 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 := {||MsgRun( emailCONNECTING1 + cPop3Host + " (" + oPop:cIPServer + ") "+emailCONNECTING2) }
oPop:bConnected := {||MsgRun ( emailCONNECTEDPOP ) }
oPop:bDone := {|o|MsgInfo (o:cStatus)}
oPop:oSocket:lDebug := .T. // uncomment to create log file
oPop:oSocket:cLogFile := "pop3.log"
oPop:GetMail( .T. ) // nur prüfen, ob Pop-server erreichbar ist
oInit:end()
Return (lRet)
//----------------------------------------------------------------------------//
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 ViewErrors ()
LOCAL oFONT,oDLG, oSay, oGet, oBtn1, oBtn2, oBtn3
LOCAL cError := ""
if !FILE(sysERRORSDIR+"ERRORS.DBF")
MSGWAIT(viewALERT1,viewALERT2)
RETURN NIL
endif
USE ( sysERRORSDIR+"ERRORS.DBF" ) ALIAS "ERRORS" SHARED
RLOCK()
cError := viewERROR1+" : "+DTOC(ERRORS->Date)+viewERROR2+ERRORS->Time+CRLF+;
viewERROR3+" : "+ERRORS->Descript+CRLF+;
viewERROR4+" : "+trim(ERRORS->User)+'/'+ERRORS->Comp+CRLF+;
viewERROR5+" : "+Errors->Picture
DEFINE FONT oFont NAME "Ms Sans Serif" SIZE 0, -10
DEFINE DIALOG oDlg SIZE 450, 350 TITLE viewERRORTitle FONT oFont TRANSPARENT
@ 4, 1 SAY oSay PROMPT viewERROR1+" : "+DTOC(ERRORS->Date)+viewERROR2+ERRORS->Time+CRLF+;
viewERROR3+" : "+ERRORS->Error+CRLF+;
viewERROR4+" : "+trim(ERRORS->User)+'/'+ERRORS->Comp+CRLF+;
viewERROR5+" : "+Errors->Picture OF oDlg FONT oFont SIZE 230, 35 ;
PIXEL UPDATE COLOR COLOR_TEXT, COLOR_BAR[2]
@ 37 ,1 GET oGET VAR ERRORS->Descript OF oDLG MULTILINE READONLY SIZE 225, 112 PIXEL UPDATE
@ 157, 5 BUTTON oBTN1 PROMPT " |< " SIZE 20,12 PIXEL OF oDLG ACTION ( DBGOTOP(),RLOCK(),oDLG:UPDATE(),oDlg:Refresh() )
@ 157, 27 BUTTON oBTN1 PROMPT " < " SIZE 20,12 PIXEL OF oDLG ACTION ( DBSKIP(-1),IF(BOF(),(MSGINFO("Beginning of File"),DBSKIP(1)),(RLOCK(),oDLG:UPDATE(),oDlg:Refresh())) )
@ 157, 49 BUTTON oBTN1 PROMPT " > " SIZE 20,12 PIXEL OF oDLG ACTION ( DBSKIP(1),IF(EOF(),(MSGINFO("End of File"),DBSKIP(-1)),(RLOCK(),oDLG:UPDATE(),oDlg:Refresh())) )
@ 157, 71 BUTTON oBTN1 PROMPT " >| " SIZE 20,12 PIXEL OF oDLG ACTION ( DBGOBOTTOM(),RLOCK(),oDLG:UPDATE(),oDlg:Refresh() )
@ 157, 97 BUTTON oBTN1 PROMPT viewBTNImg SIZE 38,12 PIXEL OF oDLG ACTION ShowErrPic(oDlg) WHEN !Empty(Errors->Picture)
@ 157, 137 BUTTON oBTN2 PROMPT viewBTNPrint SIZE 38,12 PIXEL OF oDLG ACTION PRINTERRORS()
@ 157, 182 BUTTON oBTN3 PROMPT viewBTNClose SIZE 38,12 PIXEL OF oDLG ACTION oDlg:End() DEFAULT
ACTIVATE DIALOG oDlg CENTERED ;
ON PAINT Degrade (oDlg:hDC, {0,1,72,451}, COLOR_BAR[2],COLOR_BAR[1] )
oFont:End()
ERRORS->(DBCLOSEAREA())
RETURN NIL
//---------------------------------------------------------------------
FUNCTION PrintErrors() //IMPRESION DE ERRORES
LOCAL oPRN,oFONT, cError, nLin, nLinea
PRINTER oPRN PREVIEW
DEFINE FONT oFont NAME "COURIER NEW" SIZE 0,-10 OF oPrn
PAGE
cERROR:=ERRORS->Descript
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 ShowErrPic()
LOCAL oDlg, oSay, oImage, nPos, cImgFile
// Leemos las coordenadas de la pantalla actual y definimos la resolucion (WP)
local oWnd := WndMain()
local aCoord := GetWndRect( oWnd:hWnd ), WWidth, WHeight, nFactor
LOCAL aPoint1 := {aCoord[1], aCoord[2]}, aPoint2 := {aCoord[3], aCoord[4]}
LOCAL nHeight, nWidth, aImgSize := {}
// LOCAL aT := AClone (aCoord)
ClientToScreen( oWnd:hWnd, @aPoint1 ) // convert both point coordinates
ClientToScreen( oWnd:hWnd, @aPoint2 )
WWidth := aPoint2[2] - aPoint1[2] - 65 // Breite
WHeight := aPoint2[1] - aPoint1[1] - 65 // Höhe
// ? aT[1],aT[2],aT[3],aT[4],"-----",aPoint1[1], aPoint1[2],aPoint2[1],aPoint2[2]
nPos := FieldPos ("Picture")
cImgFile := FieldGet( nPos )
cImgFile := IIF( !Empty(cImgFile), sysERRORSDIR + cImgFile, "" )
if FILE (cImgFile)
aImgSize := FISize (cImgFile)
//aImgSize := {WWidth,WHeight}
nFactor := Max ((WWidth-27)/aImgSize[1],(WHeight)/aImgSize[2])
nWidth := nFactor * aImgSize[1]
nHeight := nFactor * aImgSize[2]
// ? WWidth, WHeight,"----",aImgSize[1],aImgSize[2],"---",nWidth,nHeight
DEFINE DIALOG oDlg TITLE showPICTitle PIXEL SIZE WWidth,WHeight of oWnd//TRANSPARENT
@ 3,1 SAY oSay PROMPT CRLF+Alltrim(ERRORS->Error) OF oDlg SIZE WWidth*1.1, 27 ;
COLOR COLOR_TEXT, COLOR_BAR[1] PIXEL
// if !Empty( cImgFile )
@ 28,0 IMAGE oImage FILE cImgFile PIXEL OF oDlg;
SIZE nWidth,nHeight
// endif
ACTIVATE DIALOG oDlg CENTER //;
// ON PAINT Degrade (oDlg:hDC, {0,0,Abs(WHeight-nHeight),WWidth*1.1}, COLOR_BAR[2],COLOR_BAR[1] )
else
MSGINFO(showPICERROR1,showPICERROR2)
endif
// 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"
*/
//--------------------------------------------------------------------
// Reemplazo a SalvaraBMP
// Original de Williams Pacheco 2003 + Bingen 2003
//--------------------------------------------------------------------
function SaveBmp( hDib, cBmpFile, cFormat )
LOCAL acFormat := {"png","gif","jpg","tiff"}, anFormat := {13,25,2,18}
LOCAL nFormat := anFormat[AScan(acFormat,Lower(cFormat))]
local cRetVal := sysERRORSDIR + cBmpFile + ".BMP"
LOCAL cDestImg := sysERRORSDIR + cBmpFile + "."+cFormat
LOCAL lOk := .f.
CURSORWAIT()
DibWrite( cRetVal, hDib )
IF UPPER(cFormat) <> "BMP"
// lOk := FISaveImg(cRetval, cDestImg, nFormat)
lOk := FIConvertImageFile( cRetval, cDestImg, nFormat, 0 )
FErase (cRetVal)
cRetVal := IIF (lOk, cDestImg, "")
ENDIF
// IF UPPER(cFormat) = "JPG" .and. File( "NCONVERT.EXE" )
// WaitRun( "nconvert -out jpeg " + " -D " + ".\ERRORS\" + cBmpFile +".BMP" , 0 )
// ENDIF
CursorArrow()
//return IF(UPPER(cFormat) = "PNG",cFileName( STRTRAN(cRetVal,".BMP",".PNG" )),cFileName( cRetVal ))
RETURN (cFileName (cRetVal))
//------------------------------------------------------------------
STATIC FUNCTION ReadIni ()
LOCAL oIni, aSet :=Array(10)
LOCAL cKey := emailKEY
INI oIni FILE E_INIFILE
GET aSet[E_USER] SECTION "Email" ENTRY "User" DEFAULT "" OF oIni
GET aSet[E_LOGIN] SECTION "Email" ENTRY "Login" DEFAULT "user@"+emailDOMAIN OF oIni
GET aSet[E_PASS] SECTION "Email" ENTRY "Pass" DEFAULT "" OF oIni
GET aSet[E_POP3] SECTION "Email" ENTRY "Pop-Host" DEFAULT "pop3."+emailDOMAIN OF oIni
GET aSet[E_SMTP] SECTION "Email" ENTRY "Smpt-Host" DEFAULT "smtp."+emailDOMAIN OF oIni
GET aSet[E_CONNECT] SECTION "Email" ENTRY "Leasedline" DEFAULT .F. OF oIni
GET aSet[E_SAVE] SECTION "Email" ENTRY "Autosave" DEFAULT .T. OF oIni
GET aSet[E_DELETE] SECTION "Email" ENTRY "Maildelete" DEFAULT .T. OF oIni
GET aSet[E_FROM] SECTION "Email" ENTRY "ReplyTo" DEFAULT "" OF oIni
GET aSet[E_TO] SECTION "Email" ENTRY "MailTo" DEFAULT emailADDRESS OF oIni
// GET aSet[E_] SECTION "Email" ENTRY "Leasedline" DEFAULT .F. OF oIni
ENDINI
if empty( aSet[E_USER] )
aSet[E_USER] := gete("WHOLE_NAME")
endif
if empty( aSet[E_FROM] )
aSet[E_FROM] := gete("USERNAME")+"@"+emailDOMAIN
endif
aSet[E_PASS] := Crypt(aSet[E_PASS],cKey)
RETURN (aSet)
#define HKEY_LOCAL_MACHINE 2147483650 // 0x80000002
function GetCPU()
local oReg := TReg32():New( HKEY_LOCAL_MACHINE,;
"HARDWARE\DESCRIPTION\System\CentralProcessor\0",;
.f. )
local cCpu := oReg:Get( "ProcessorNameString" )
oReg:Close()
return cCpu
//-----------------------------------------------------------------//
STATIC FUNCTION Degrade ( hDC, aRect, nColor, nColorTo )
//LOCAL aRect := GETCLIENTRECT( oWnd:hWnd )
LOCAL nStep , nStepY /// 256
LOCAL oBrush
LOCAL i, r,g,b
LOCAL r0,g0,b0
LOCAL r1, g1, b1
LOCAL rD, gD, bD
DEFAULT nColorTo := nRGB (250,250,250)
//nColor := nRGB (255,0,0)
nStep := ( aRect[ 3 ] - aRect[ 1 ] )
nStepY := ( aRect[ 3 ] - aRect[ 1 ] ) / nStep
aRect[ 3 ] = aRect[ 1 ] + nStepY
r0 := nRGBRed (nColor)
g0 := nRGBGreen (nColor)
b0 := nRGBBlue (nColor)
r1 := nRGBRed (nColorTo)
g1 := nRGBGreen (nColorTo)
b1 := nRGBBlue (nColorTo)
rD := r1-r0
gD := g1-g0
bD := b1-b0
r := 256*rD/Max(nStep,1)
g := 256*gD/Max(nStep,1)
b := 256*bD/Max(nStep,1)
r0*=256
g0*=256
b0*=256
// ? R + G*256 + B*256*256, nColor
// ? rD, gD, bD, "---",r, g, b
FOR i = 0 TO nStep-1 STEP nStepY
r0 += r
g0 += g
b0 += b
DEFINE BRUSH oBrush COLOR nRGB( r0/256, g0/256, b0/256 )
FILLRECT( hDC, aRect, oBrush:hBrush )
RELEASE BRUSH oBrush
// ? r0/256, g0/256,b0/256, nRGB( r0/256, g0/256, b0/256 ),aRect[1], aRect[3]
aRect[ 1 ] += nStepY
aRect[ 3 ] += nStepY
NEXT
RETURN (nil)
// If image.prg does not have this function then you can uncomment the code below
/*
function fisize( cImgFile )
local oBmp, aReturn
if file( cImgFile )
DEFINE IMAGE oBMP FILENAME cImgFile
aReturn := {oBMP:nWidth(), oBMP:nHeight()}
else
aReturn := {0,0}
endif
oBMP
return( aReturn )
*/
)
