// Error handler system adapted to FiveWin// ErrSysW.prg#include "error.ch"#include "FiveWin.ch"external _fwGenError
// Link FiveWin generic Error Objects Generator#define NTRIM
(n
) ( LTrim
( Str
( n
) ) )#ifdef __HARBOUR__
#define DLG_TITLE
"Message" #command QUIT =>
( PostQuitMessage
( 0 ), __Quit
() )#endif
/*************
* ErrorSys()
*
* Note: automatically executes at startup
*/proc ErrorSys
() ErrorBlock
( { | e | ErrorDialog
( e
) } )returnproc ErrorLink
()return/*************
* ErrorDialog()
*/static function ErrorDialog
( e
) // -> logical or quits App.local oDlg, oLbx, oFont, oFont1
local lRet
// if lRet == nil -> default action: QUITlocal n, j, cMessage, aStack :=
{}local oSay, hLogo
local nButtons :=
1local cErrorLog :=
""local aVersions := GetVersion
()local aTasks
local aRDDs, nTarget, uValue
local oOldError, c_pfad, cerr, cerr1, cerr2, cerr3, i, xxx, x
local cRelation, lNetOpt
local lIsWinNT := IsWinNT
()// by default, division by zero yields zeroif ( e:
genCode == EG_ZERODIV
) return 0endif// for network open error, set NETERR() and subsystem defaultif ( e:
genCode == EG_OPEN .and. ;
( e:
osCode ==
32 .or. e:
osCode ==
5 ) .and. ;
e:
canDefault ) NetErr
( .t.
) return .f.
// Warning: Exiting!endif// for lock error during APPEND BLANK, set NETERR() and subsystem defaultif ( e:
genCode == EG_APPENDLOCK .and. e:
canDefault ) NetErr
( .t.
) return .f.
// OJO SALIDAendifif Left( ProcName
( 7 ),
10 ) ==
"ERRORDIALO" CLOSE ALL
SET RESOURCES
TO ErrorLevel
( 1 ) QUIT
endifErrorBlock
( {|e| MsgStop
( ErrorMessage
(e
) +
" from Errorsys, Line :" + ;
Str
( ProcLine
(1),
3 ) ), __quit
() } ) // 1cErrorLog +=
"Application "+MEMVAR->cModule+
" "+MEMVAR->cEXEVersion + CRLF
cErrorLog +=
"Customer : "+MEMVAR->Coname + CRLF
cErrorLog +=
"User ID : "+MEMVAR->us_name + CRLF
cErrorLog +=
"Station ID : "+MEMVAR->Networks + CRLF
cErrorLog +=
"Path : "+MEMVAR->cPath + CRLF
cErrorLog +=
"RDD : "+MEMVAR->cRDD + CRLF
cErrorLog +=
"==========================" + CRLF
cErrorLog +=
"Path and name : " + GetModuleFileName
( GetInstance
() )#ifdef __CLIPPER__
cErrorLog +=
" (16 bits)" + CRLF
#else
cErrorLog +=
" (32 bits)" + CRLF
#endif
cErrorLog +=
"Sizes : " + Transform
( FSize
( GetModuleFileName
( ;
GetInstance
() ) ),
"9,999,999 bytes" ) + CRLF
#ifdef __CLIPPER__
cErrorLog +=
" Max files handles permited : ( SetHandleCount() ) " + ;
Str
( SetHandleCount
(),
3 ) + CRLF
#endif
cErrorLog +=
"Time from start : " + TimeFromStart
() + CRLF
cErrorLog +=
"Error occurred at : " + ;
DToC
( Date
() ) +
", " + Time
() + CRLF
// Error object analysiscMessage =
"Description : " + ErrorMessage
( e
) + CRLF
cErrorLog += cMessage
if ValType
( e:
Args ) ==
"A" cErrorLog +=
" Args:" + CRLF
for n =
1 to Len
( e:
Args ) cErrorLog +=
" [" + Str
( n,
4 ) +
"] = " + ValType
( e:
Args[ n
] ) + ;
" " + cValToChar
( e:
Args[ n
] ) + CRLF
nextendifcErrorLog += CRLF +
"Stack Calls" + CRLF
cErrorLog +=
"==========================" + CRLF
n :=
2 // we don't disscard any info again !while ( n <
74 ) if ! Empty
(ProcName
( n
) ) AAdd
( aStack,
" Called from : " + ProcFile
( n
) +
" => " + Trim
( ProcName
( n
) ) + ;
"(" + NTRIM
( ProcLine
( n
) ) +
")" ) cErrorLog += ATail
( aStack
) + CRLF
endif n++
end
cErrorLog += CRLF +
"System" + CRLF
cErrorLog +=
"======" + CRLF
#ifdef __CLIPPER__
cErrorLog +=
" CPU type: " + GetCPU
() + CRLF
#else
cErrorLog +=
" CPU type: " + GetCPU
() +
" " + ;
AllTrim
( Str
( GetCPUSpeed
() ) ) +
" Mhz" + CRLF
#endif
cErrorLog +=
" Hardware Memory: " + ;
cValToChar
( Int
( nExtMem
() /
( 1024 *
1024 ) ) +
1 ) + ;
" megs" + 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
#ifdef __CLIPPER__
cErrorLog +=
" Windows and MsDos versions : " + ;
AllTrim
( Str
( aVersions
[ 1 ] ) ) +
"." + ;
AllTrim
( Str
( aVersions
[ 2 ] ) ) +
", " + ;
AllTrim
( Str
( aVersions
[ 3 ] ) ) +
"." + ;
AllTrim
( Str
( aVersions
[ 4 ] ) ) + CRLF + CRLF
#else
cErrorLog +=
" Windows-version: " + ;
AllTrim
( Str
( aVersions
[ 1 ] ) ) +
"." + ;
AllTrim
( Str
( aVersions
[ 2 ] ) ) +
", Stand " + ;
AllTrim
( Str
( aVersions
[ 3 ] ) ) + ;
" " + aVersions
[ 5 ] + CRLF + CRLF
#endif
aTasks = GetTasks
()cErrorLog +=
" Windows total applications running : " + ;
AllTrim
( Str
( Len
( aTasks
) ) ) + CRLF
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 bitmapif e:
canRetry nButtons++
endifif e:
canDefault nButtons++
endifcErrorLog += CRLF +
"Variables in use " + CRLF +
"====================" + CRLF
cErrorLog +=
" Procedure Type Value" + CRLF
cErrorLog +=
" ==========================" + CRLF
n :=
2 // we don't disscard any info again !while ( n <
74 ) if ! Empty
( ProcName
( n
) ) 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 +
"Linked RDDs" + CRLF +
"=============" + CRLF
aRDDs = RddList
( 1 )for n =
1 to Len
( aRDDs
) cErrorLog +=
" " + aRDDs
[ n
] + CRLF
nextcErrorLog += CRLF +
"DataBases in use " + 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
() ),
"9999999" ) + ;
" " + Transform
( ( Alias( n
) )->
( RecCount
() ),
"9999999" ) + ;
" " + cValToChar
( ( Alias( n
) )->
( BoF
() ) ) + ;
" " + cValToChar
( ( Alias( n
) )->
( EoF
() ) ) + CRLF + CRLF
if ( Alias( n
) )->
( RddName
() ) !=
"ARRAYRDD" cErrorLog +=
" Indexes in use " + 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 +
" Relations in use : " + 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 endifnextn =
1cErrorLog += CRLF +
"Classes in use :" + CRLF
cErrorLog +=
"==================" + CRLF
#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
#ifdef __CLIPPER__
cErrorLog +=
" Static memory :" + CRLF
cErrorLog +=
" Data Segment : 64k" + CRLF
#endif
#ifdef __CLIPPER__
cErrorLog +=
" Initial size : " + ;
LTrim
( Str
( nInitDSSize
() ) ) + ;
" bytes (SYMP=" + LTrim
( Str
( nSymPSize
() ) ) + ;
", Stack=" + LTrim
( Str
( nStackSize
() ) ) + ;
", Heap=" + LTrim
( Str
( nHeapSize
() ) ) +
")" + CRLF
cErrorLog +=
" PRG Stack: " + ;
LTrim
( Str
( 65535 -
( nStatics
() *
14 ) - nInitDSSize
() ) ) + ;
" bytes" + CRLF
#endif
#ifdef __CLIPPER__
cErrorLog +=
" " + LTrim
( Str
( nStatics
() ) ) +
" Static variables : " + ;
LTrim
( Str
( nStatics
() *
14 ) ) +
" bytes" + CRLF + CRLF
#else
cErrorLog +=
" " + LTrim
( Str
( nStatics
() ) ) +
" Static variables" + ;
CRLF + CRLF
#endif
cErrorLog +=
" Dynamic memory consume :" + CRLF
cErrorLog +=
" Actual Value : " + Str
( MemUsed
() ) +
" bytes" + CRLF
cErrorLog +=
" Highest Value : " + Str
( MemMax
() ) +
" bytes" + CRLF
// nSymNames() no longer returns a real value! 15/April/97/*
cErrorLog += " SYMBOLS segment" + CRLF
cErrorLog += " " + LTrim( Str( nSymNames() ) ) + " SymbolNames: " + ;
LTrim( Str( nSymNames() * 16 ) ) + " bytes"
*/// you can save max 10 Error-messages// then it starts with 1 again// ------------------------- programm-name// c_dir := GetModuleFilename(GetInstance(),"BOS32.EXE" + CHR(0), 255)// c_pfad := left ( c_dir, rat( "\", c_dir) -1 )// c_pfad = Path of applicationc_pfad := MEMVAR->cPath+
'LOG'if !lIsDir
(MEMVAR->cPath+
'LOG') lMkDir
(MEMVAR->cPath+
'LOG')end
cERR :=
""cERR1 :=
""n :=
0BEGIN SEQUENCE
oOldError = ErrorBlock
( { || DoBreak
() } ) // ------------- NEW -------------------------------------- i :=
0 do while i <=
100 i++
xxx := strzero
(i,
2) cERR := c_pfad+
"\LOGER_" + xxx +
".LOG" if !File
(cERR
) .or. i =
100 // deletes the old error.log`s // --------------------------------- IF i =
100 cERR := c_pfad+
"\LOGER_01.LOG" x :=
1 FOR x :=
1 TO 99 xxx := strzero
(x,
2) cERR1 := c_pfad+
"\LOGER_" + xxx +
".LOG" DELETE FILE &cERR1
NEXT MemoWrit
( cERR, cErrorLog
) EXIT
ELSE IF !FILE
( cERR
) MemoWrit
( cERR, cErrorLog
) EXIT
ENDIF ENDIF ENDIF end
cERR3 := c_pfad+
"\LOGER_" + xxx +
".LOG" cERR2 :=
"LOGER_" + xxx +
".LOG" // -------------------------------------------END SEQUENCE
ErrorBlock
( oOldError
)lNetOpt := IsInternet
()if lNetOpt
// SendLog( cERR3 )end
DEFINE FONT oFont
NAME "Arial" SIZE -6,
0 DEFINE DIALOG oDlg
TITLE DLG_TITLE
SIZE 600,
130 FONT oFont
@
7,
0 SAY oSay
PROMPT OemToAnsi
( cMessage
) ;
CENTERED OF oDlg
FONT oFont
SIZE 300,
20 PIXEL oSay:
nStyle = nOR
( oSay:
nStyle,
128 ) // SS_NOPREFIX n = aStack
[ 1 ] @
20,
20 BUTTON "View Log file" OF oDlg
FONT oFont ;
SIZE 80,
12 PIXEL ;
ACTION WinExec
( "Notepad.exe "+cERR3
) if lNetOpt
@
20,
110 BUTTON "Email to Support" OF oDlg
FONT oFont ;
SIZE 80,
12 PIXEL ;
ACTION (SendLog
( cERR3
), oDlg:
End()) end
@
20,
200 BUTTON "E&xit" OF oDlg
FONT oFont ;
SIZE 80,
12 PIXEL ;
ACTION oDlg:
End() ;
DEFAULT // Here you can write a message what to do with the ERROR1 - 30.log @
38,
10 SAY "Please contact EASYFO Support and send log file <"+cERR2+
">" OF oDlg
FONT oFont
PIXEL SIZE 280,
12 CENTERED @
50,
10 SAY MEMVAR->cContInfo
OF oDlg
FONT oFont1
PIXEL SIZE 280,
12 CENTEREDACTIVATE DIALOG oDlg
CENTERED if lRet ==
nil .or.
( !LWRunning
() .and. lRet
) SET RESOURCES
TO ErrorLevel
( 1 ) CLOSE ALL
QUIT
// must be QUIT !!!endifreturn lRet
//----------------------------------------------------------------------------//static function DoBreak
()BREAKreturn nil//----------------------------------------------------------------------------//static func ErrorMessage
( e
)// start error messagelocal cMessage :=
if( empty
( e:
OsCode ), ;
if( e:
severity > ES_WARNING,
"Error ",
"Warning " ),;
"(DOS Error " + NTRIM
(e:
osCode) +
") " )// add subsystem name if availablecMessage +=
if( ValType
( e:
SubSystem ) ==
"C",;
e:
SubSystem() ,;
"???" )// add subsystem's error code if availablecMessage +=
if( ValType
( e:
SubCode ) ==
"N",;
"/" + NTRIM
( e:
SubCode ) ,;
"/???" )// add error description if availableif ( ValType
( e:
Description ) ==
"C" ) cMessage +=
" " + e:
Descriptionendif// add either filename or operationcMessage +=
if( ! Empty
( e:
FileName ),;
": " + e:
FileName ,;
if( !Empty
( e:
Operation ),;
": " + e:
Operation ,;
"" ) )return cMessage
//----------------------------------------------------------------------------//// returns extended info for a certain variable typestatic 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
)endcasereturn nil*--------------------------------------------*
Static Function SendLog
( cFileName, lNoMsg
)local mDlg, oSay, oGet
[4], oBtn
[2]local lOk := .F., lStart := .T.
local cAtt, cSub, cText, cTo, cSender, cPass, cDisplay, cReply, lSave
local cFile
Default lNoMsg := .F.
if IsInternet
() cFile :=
'' if file
( cFileName
) cAtt := cFileName
cFile:= subs
(cFileName,
at('.LOG',cFileName
)-8,
12) else lStart := .F.
MsgAlert
('Log File is missing, Cannot Send now!') end
if lStart
cPass :=
'password' cDisplay :=
'(EASYFO support)' cSender :=
'myemail@gmail.com' cReply :=
'myemail@gmail.com' cSub :=
left('Send Log File : '+cFile+
' from '+rtrim
(MEMVAR->coname
)+space
(100),
100) cTo :=
left(MEMVAR->cMailSupport+space
(100),
100) lSave := .T.
if file
( cAtt
) MsgRun
("This messages is sending now",;
"E-mail is sending, please wait...",;
{ | oDlg | UpCaption
( oDlg, cSender, cPass, cDisplay, cReply, lSave, rtrim
(cTo
), cSub, cAtt, cSub
) } ) end
end
else MsgStop
('Please check your internet connection before use')end
return nil *---------------------------------------------------------------------------------------------------*
Static function UpCaption
( oDlg, cSender, cPass, cDisplay, cReply, lSave, cTo, cSubject, cAtt, cMsg
) local n, lMsgInfo, cCC :=
''lMsgInfo := .F.
SendMail
( oDlg, cSender, cPass, cDisplay, cReply, lSave, cTo, cCC, cSubject, cMsg, .F., cAtt, .T.
)oDlg:
cMsg :=
"The messages have sent successfully "oDlg:
Refresh()SysRefresh
()return nil **************************************************************
*****
New SendMail by GMail
**************************************************************
*-------------------------------------------------------------------------------------------------------------------------------*
Static Function SendMail
( oDlg, cSender, cPass, cDisplay, cReply, lSave, cTo, cCC, cSubject, cMsg, lReceipt, cAttach, lMsgInfo, cGstNo
)*-------------------------------------------------------------------------------------------------------------------------------*
Local oEmailCfg,oEmailMsg,oError,cHtml, cLine, n
local nSuccess
nSuccess :=
1Default lReceipt := .T., lMsgInfo := .F., lSave := .T., cAttach :=
'', cSubject :=
'', cDisplay := MEMVAR->coname, cMsg :=
'', cCC :=
'', ;
cReply := cSender, cGstNo :=
''cMsg := alltrim
(cMsg
)CursorWait
()cHtml:=
'<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">'cHtml+=
'<HTML><HEAD>'cHtml+=
'<META content="text/html; charset=windows-874" http-equiv=Content-Type>'cHtml+=
'<META name=GENERATOR content="MSHTML 8.00.6001.18783">'cHtml+=
'<STYLE></STYLE>'cHtml+=
'</HEAD>'cHtml+=
'<BODY bgColor=#ffffff>'cHtml+=
'<DIV>'// cHtml += '<DIV><FONT size=2 color=blue face=Arial>Hello How are you ?</FONT></DIV></BODY></HTML>'// cHtml += cMsgfor n :=
1 to MLCount
( cMsg
) cLine := rtrim
(memoline
( cMsg,
100, n
)) cHtml += cLine+
"<br>" // HB_readline( cMsg )nextcHtml+=
'</DIV></BODY></HTML>'TRY oEmailCfg := CREATEOBJECT
( "CDO.Configuration" ) WITH OBJECT oEmailCfg:
Fields :
Item( "http://schemas.microsoft.com/cdo/configuration/smtpserver" ):
Value :=
"smtp.gmail.com" :
Item( "http://schemas.microsoft.com/cdo/configuration/smtpserverport" ):
Value :=
465 :
Item( "http://schemas.microsoft.com/cdo/configuration/sendusing" ):
Value :=
2 // Remote SMTP = 2, local = 1 :
Item( "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate" ):
Value := .T.
:
Item( "http://schemas.microsoft.com/cdo/configuration/smtpusessl" ):
Value := .T.
:
Item( "http://schemas.microsoft.com/cdo/configuration/savesentitems" ):
Value := lSave
:
Item( "http://schemas.microsoft.com/cdo/configuration/sendusername" ):
Value := cSender
// "hotel@gmail.com" :
Item( "http://schemas.microsoft.com/cdo/configuration/sendpassword" ):
Value := cPass
// Password :
Item( "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"):
Value :=
60 :
Update() END WITH
CATCH oError
if lMsgInfo
MsgAlert
("Could not send message" +CRLF+ ;
"Error: " + TRANSFORM
(oError:
GenCode,
NIL) +CRLF+ ;
"SubC: " + TRANSFORM
(oError:
SubCode,
NIL) +CRLF+ ;
"OSCode: " + TRANSFORM
(oError:
OsCode,
NIL) +CRLF+ ;
"SubSystem: " + TRANSFORM
(oError:
SubSystem,
NIL) +CRLF+ ;
"Message: " + oError:
Description ) else nSuccess :=
0 end
END
oError:=
NILTRY oEmailMsg := CREATEOBJECT
( "CDO.Message" ) WITH OBJECT oEmailMsg
:
Configuration := oEmailCfg
:
From := chr
(34)+cDisplay+
" "+chr
(34)+
"<"+cReply+
">" // cSender // This will be displayed in the From (The email id does not appear) :
To := cTo
// "dutch@easyfo.com" // <----- Place your email address :
Subject := cSubject
// "Email Test Message from GMail" :
ReplyTo := cReply
:
MDNRequested := .F.
if !empty
(cAttach
) :
AddAttachment(cAttach
) end
:
HTMLBody = cHtml
END WITH
oEmailMsg:
Send()CATCH oError
if lMsgInfo
MsgAlert
("Could not send message" +
";" + CRLF+ ;
"Error: " + TRANSFORM
(oError:
GenCode,
NIL) +
";" + CRLF+;
"SubC: " + TRANSFORM
(oError:
SubCode,
NIL) +
";" + CRLF+ ;
"OSCode: "+ TRANSFORM
(oError:
OsCode,
NIL) +
";" + CRLF +;
"SubSystem: " + TRANSFORM
(oError:
SubSystem,
NIL) +
";" +CRLF+ ;
"Message: " + oError:
Description ) else nSuccess :=
0 end
END
CursorArrow
()Return nSuccess
//----------------------------------------------------------------------------//#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
//----------------------------------------------------------------------------//#ifdef __HARBOUR__
#ifndef __XHARBOUR__
REQUEST HB_GT_GUI
procedure HB_GTSYS
() ;
return procedure HB_GT_GUI_DEFAULT
() ;
return procedure FW_GT ;
return #endif
#endif
//----------------------------------------------------------------------------// 
Posted: Sat Sep 16, 2017 3:29 pm
