Page 1 of 3

Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 7:43 am
by yeangpumpeng
Hello

I think Errsysw .prg need a visual and functional update like Email sending save error in a database etc

It looks ver yold

Something like copy the Line of the last error into the clipboard or starts a macro with uestudio to goto the line

or why open the error log with notepad

Tx

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 9:37 am
by Antonio Linares
Yeang,

Thanks for your feedback,

What visual changes would you propose ?

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 11:11 am
by yeangpumpeng

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 11:48 am
by Otto
In my opinion “Ignore and continue” is very dangerous.
Best regards,
Otto

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 1:25 pm
by StefanHaupt
Antonio,

some years ago I made such a system, it was a modification of the source code of Jose Carlos da Rocha, see the headline in the source. Maybe this can be the startpoint of modern looking errorsystem.

Errors are saved in a dbf, they can be send as email and a picture is taken from the application.

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)

// 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 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, 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"

#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 "An error occured."+CRLF+;
                   "Please inform your dealer about this error and "+CRLF+;
                   "the circumstances it happened."
  #define dlgTEXT2 "Errordescription:"

  #define BTN_Header  "Errorinformation"
  #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 emailADDRESS "yourEmailHere"
  #define emailKEY     "yourPassHere"
#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 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

    // 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..." ) }
*/

    /* 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 ),;
                      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_BAR[2],COLOR_BAR[1] ) );
             VALID (oFont:End(), oFont1:End(),.t.)


    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

//        IF cUser <> "DPD"                //NO SE GRABAN SI SOMOS NOSOTROS

            IF !FILE("ERRORS\ERRORS.DBF")
                DbCreate("ERRORS\ERRORS.DBF",;
                          {{"Comp","C",11,0},{"Date","D",8,0},;
                           {"Time","C",8,0},{"Error","C",76,0},;
                           {"Descript","M",10,0},{"Picture","C",30,0} })
            ENDIF

            SET PRINTER OFF
            SET CONSOLE ON
            USE "ERRORS\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

            hBmp := WndBitmap( oWnd:hWnd )
            hDib := DibFromBitmap( hBmp )
            cImgFile := "Err" + StrZero( RecNo(), 5 )

            aScreens:=DIRECTORY("ERRORS\*.png")
            aScreens:=ASORT(aScreens,,, { |x, y| x[1] < y[1] })
            FOR nScreen:=1 TO LEN(aScreens)-nScreens
             DELETE FILE ("ERRORS\"+aScreens[nScreen,1])    // delete all files more than 30
            NEXT
            REPLACE Picture WITH SaveBmp( hDib, cImgFile, "png" )
            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 SendEmail (cSubject, cBody, cMsg, oWnd)

  LOCAL oInit, oMail, aSet, i, lOk := .f.
  LOCAL lReceipt  := .f.
  LOCAL lAuth     := .f.
  LOCAL cFrom

  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 ("Email-Einstellungen fehlerhaft","Email versenden")
    RETURN (nil)
  ENDIF
  FErase ("Smtp.log")         // delete old logfile

  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_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( "Connecting to " + aSet [E_SMTP] + " (" + oMail:cIPServer + ") and waiting for response...") }
  oMail:bConnected       := {||MsgRun ("Email wird versandt...") }
//  oMail:bConnecting      := {|| oWnd:SetMsg( "Connecting to " + cSmtpHost + " (" + oMail:cIPServer + ") and waiting for response..." ) }
//  oMail:bConnected       := {|| oWnd:SetMsg( "Email wird versandt..." ) }
  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
        { "error.log" }, ;              //  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( "Connecting to " + cPop3Host + " (" + oPop:cIPServer + ") and waiting for response...") }
   oPop:bConnected       := {||MsgRun ("Checking for email messages...") }
//   oPop:bConnecting := {|| oWnd:SetMsg( "Connecting to " + cPOP3Host + " (" + oPop:cIPServer + ") and waiting for response..." ) }
//   oPop:bConnected  := {|| oWnd:SetMsg( "Checking for email messages..." ) }
   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("ERRORS\ERRORS.DBF")
     MSGWAIT("Die Fehlerprotokolldatei fehlt","Fehlerprotokolles")
     RETURN NIL
    endif

    USE "ERRORS\ERRORS.DBF" ALIAS "ERRORS" SHARED
    RLOCK()

    cError := "Datum des Fehlers  : "+DTOC(ERRORS->Date)+"   Uhrzeit   "+ERRORS->Time+CRLF+;
              "Fehlerbeschreibung : "+ERRORS->Descript+CRLF+;
              "Nutzer/PC          : "+ERRORS->Comp+CRLF+;
              "Grafik             : "+Errors->Picture

    DEFINE FONT oFont NAME "Ms Sans Serif" SIZE 0, -10

    DEFINE DIALOG oDlg SIZE 450, 350 TITLE "Fehlerprotokolle ansehen" FONT oFont TRANSPARENT
//    SetBkMode (oDlg:hDC, 1)
//    DrawTextEx (oDlg:hDC, cError,{0,1,72,451},0)
    @ 4, 1 SAY oSay PROMPT  errTIME+DTOC(ERRORS->Date)+"   Uhrzeit   "+ERRORS->Time+CRLF+;
                            errDESC+ERRORS->Error+CRLF+;
                            "Nutzer/PC          : "+ERRORS->Comp+CRLF+;
                            "Grafik             : "+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("Dateianfang"),DBSKIP(1)),(RLOCK(),oDLG:UPDATE(),oDlg:Refresh())) )
    @ 157, 49 BUTTON oBTN1 PROMPT "  >  " SIZE 20,12 PIXEL OF oDLG ACTION ( DBSKIP(1),IF(EOF(),(MSGINFO("Dateiende"),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 "Fehlergrafik" SIZE 38,12 PIXEL OF oDLG ACTION ShowErrPic (oDlg) WHEN !Empty(Errors->Picture)
    @ 157, 137 BUTTON oBTN2 PROMPT "Drucken"      SIZE 38,12 PIXEL OF oDLG ACTION PRINTERRORS()
    @ 157, 182 BUTTON oBTN3 PROMPT "Schließen"    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]     // Breite
    WHeight := aPoint2[1] - aPoint1[1]     // 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), "ERRORS\" + cImgFile, "" )

    if FILE (cImgFile)

      aImgSize := FISize (cImgFile)
      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 "Fehlergrafik" PIXEL SIZE WWidth*1.1,(WHeight+30)*1.1 //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("Keine Grafik vorhanden","Fehlergrafik")
    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 := "ERRORS\" + cBmpFile + ".BMP"
LOCAL cDestImg := "ERRORS\" + cBmpFile + "."+cFormat
LOCAL lOk := .f.

    CURSORWAIT()
    DibWrite( cRetVal, hDib )

    IF UPPER(cFormat) <> "BMP"
      lOk := FISaveImg (cRetval, cDestImg, nFormat)
      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 "" OF oIni
    GET aSet[E_PASS]       SECTION "Email" ENTRY "Pass"       DEFAULT "" OF oIni
    GET aSet[E_POP3]       SECTION "Email" ENTRY "Pop-Host"   DEFAULT "" OF oIni
    GET aSet[E_SMTP]       SECTION "Email" ENTRY "Smpt-Host"  DEFAULT "" 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

  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)
and a sample

Code: Select all

#include "Fivewin.ch"

#define SS_SUNKEN 4096

REQUEST DBFFPT
REQUEST ordKeyGoTo

Function Main ()

local oWnd
LOCAL a := 1,;
      b := "Hallo"

REQUEST DBFCDX
REQUEST DBFFPT
REQUEST ordKeyGoTo
RDDSETDEFAULT ("DBFCDX")
SET AUTOPEN OFF

define window oWnd from 1,1 to 20,60 title "Test"

 @ 100,60 BUTTON "&Test" OF oWnd ACTION ErrTest (a,b) ;
          SIZE 40, 20 PIXEL

 @ 140,60 BUTTON "&View" OF oWnd ACTION ViewErrors (); //ErrDlg (a,b) ;
          SIZE 60, 20 PIXEL

 DEFINE MESSAGE OF oWnd PROMPT "Messagebar"

Activate Window oWnd //on Paint Err(a,b)

RETURN (nil)

function Errtest (a,b)
//  ? "Test Errorsys", IIF (Empty(WndMain()),"nil","object")


  ? b / a
  return (nil)

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 1:55 pm
by Gale FORd
Stefan,

I thought I would try your example code but there are a couple of functions missing.
fisize
fisaveimg

Do you have code for these functions?

Thanks

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 3:20 pm
by StefanHaupt
Gale,

I used a modified image.prg. here it is

Code: Select all

// 16.09.05 Konvertieren von 32bit bmp zu 24bit beim Speichern als jpeg

#include "FiveWin.ch"
#include "Constant.ch"
#include "Inkey.ch"

#define GW_CHILD      5
#define GW_HWNDNEXT   2
#define RT_BITMAP     2

#define MB_ICONEXCLAMATION 48

#ifdef __XPP__
   #define New        _New
   #define Super      ::TBitmap
#endif


STATIC hLib

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

CLASS TImage FROM TBitmap

   CLASSDATA lRegistered AS LOGICAL

   METHOD New( nTop, nLeft, nWidth, nHeight, cResName, cBmpFile, lNoBorder,;
               oWnd, bLClicked, bRClicked, lScroll, lStretch, oCursor,;
               cMsg, lUpdate, bWhen, lPixel, bValid, lDesign ) CONSTRUCTOR

   METHOD Define( cResName, cBmpFile, oWnd ) CONSTRUCTOR

   METHOD LoadImage( cResName, cBmpFile )
   METHOD Progress (lProgress)

   METHOD SaveImage( cFile, nFormat, nFlag )

  METHOD GetHeight (hBmp)
  METHOD GetWidth (hBmp)

ENDCLASS

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

METHOD New( nTop, nLeft, nWidth, nHeight, cResName, cBmpFile, lNoBorder,;
            oWnd, bLClicked, bRClicked, lScroll, lStretch, oCursor,;
            cMsg, lUpdate, bWhen, lPixel, bValid, lDesign ) CLASS TImage

   #ifdef __XPP__
      ::lRegistered = .f.
   #endif

   Super:New( nTop, nLeft, nWidth, nHeight, cResName, cBmpFile, lNoBorder, ;
              oWnd, bLClicked, bRClicked, lScroll, lStretch, oCursor,      ;
              cMsg, lUpdate, bWhen, lPixel, bValid, lDesign )
return Self

//----------------------------------------------------------------------------//
// This method does not create a control, it just creates a bitmap object to
// be used somewhere else.
METHOD Define( cResName, cBmpFile, oWnd ) CLASS TImage

   local aBmpPal

   DEFAULT oWnd := GetWndDefault()

   ::oWnd     = oWnd
   ::nZoom    = 1
   ::hWnd     = 0
   ::hBitmap  = 0
   ::hPalette = 0

   if ! Empty( cResName )
      aBmpPal    = PalBmpLoad( cResName )
      ::hBitmap  = aBmpPal[ 1 ]
      ::hPalette = aBmpPal[ 2 ]
      cBmpFile  = nil
   endif

   if ! Empty( cBmpFile ) .and. File( cBmpFile )
      ::cBmpFile = cBmpFile
      ::hBitmap = FILoadImg( AllTrim( cBmpFile ) )
   endif

   if ::hBitmap != 0
      PalBmpNew( 0, ::hBitmap, ::hPalette )
   endif

return Self

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

METHOD LoadImage( cResName, cBmpFile ) CLASS TImage

   local lChanged := .f.
   local hOldBmp  := ::hBitmap
   local hOldPal  := ::hPalette
   local aBmpPal

   DEFAULT cResName := ::cResName, cBmpFile := ::cBmpFile

   if ! Empty( cResName )
      aBmpPal    = PalBmpLoad( cResName )
      ::hBitmap  = aBmpPal[ 1 ]
      ::hPalette = aBmpPal[ 2 ]
      lChanged   = .t.
      cBmpFile   = nil
   elseif File( cBmpFile )
      ::hBitmap = FILoadImg( AllTrim( cBmpFile ) )
      lChanged  := .t.
      cResName  := nil
   endif

   if lChanged

      ::cResName = cResName
      ::cBmpFile = cBmpFile

      if ! Empty( hOldBmp )
         PalBmpFree( hOldBmp, hOldPal )
      endif

      PalBmpNew( ::hWnd, ::hBitmap, ::hPalette )

   endif

return lChanged

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

METHOD Progress( lProgress ) CLASS TImage

   if ValType( lProgress ) == "L"
      if lProgress
         ::nProgress = 1
      else
         ::nProgress = 0
      endif
   endif

return nil




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

METHOD SaveImage( cFile, nFormat, nFlag ) CLASS TImage

   //   0 -> Bmp
   //   2 -> Jpg
   //  13 -> Png

return (FISaveImg( ::cBmpFile, cFile, nFormat, nFlag ))

//----------------------------------------------------------------------------//
METHOD GetHeight (cFile)

LOCAL nRet := 0


  nRet := FISize(cFile)[1]


RETURN (nRet)

//----------------------------------------------------------------------------//
METHOD GetWidth (cFile)

LOCAL nRet := 0

  nRet := FISize(cFile)[2]


RETURN (nRet)



#define CBM_INIT 4
#define DIB_RGB_COLORS 0

//----------------------------------------------------------------------------//
FUNCTION FILoadImg( cFile )

    LOCAL nFormat, hDib, hInfoH, hInfo, hBits, hWnd, hDC, hBmp

   #ifdef __CLIPPER__
     hLib = LOADLIB32( "freeimage.dll" )
   #else
     hLib = LOADLIBRARY( "freeimage.dll" )
   #endif

    if hLib <= 32
        MsgStop( "Cannot load FreeImage.dll" )
        return 0
    endif

    nFormat = FIGETFILETYPE( cFile, 0 )
    hDib    = FILOAD( nFormat, cFile, 0 )
    hInfoH  = FIGETINFOHEADER( hDib )
    hInfo   = FIGETINFO( hDib )
    hBits   = FIGETBITS( hDib )
    hWnd    = GETDESKTOPWINDOW()

   #ifdef __CLIPPER__
     hDC = GETDC32( hWnd )
   #else
     hDC = GETDC( hWnd )
   #endif

    hBmp = CREATEDIBITMAP( hDC, hInfoH, CBM_INIT, hBits, hInfo, DIB_RGB_COLORS )

   #ifdef __CLIPPER__
     RELEASEDC32( hWnd, hDC )
   #else
     RELEASEDC( hWnd, hDC )
   #endif

    FIUNLOAD( hDib )

   #ifdef __CLIPPER__
     FREELIB32( hLib )
   #else
     FREELIBRARY( hLib )
   #endif

   #ifdef __CLIPPER__
     hBmp = NLOWORD( WOWHANDLE16( hBmp, 8 ) )
   #endif

RETURN (hBmp)


//-----------------------------------------------------------------------------
FUNCTION FISaveImg ( cSrcFile, cDstFile, nDstFormat )

   LOCAL nSrcFormat, hDib, lOk

   #ifdef __CLIPPER__
     hLib = LOADLIB32( "freeimage.dll" )
   #else
     hLib = LOADLIBRARY( "freeimage.dll" )
   #endif

    nSrcFormat = FIGETFILETYPE( cSrcFile, 0 )

    hDib = FILoad( nSrcFormat, cSrcFile, 0 )
//    ? cSrcFile, nSrcformat, hDib, cDstFile
    lOk = FISave( nDstFormat, hDib, cDstFile, 0 )

   #ifdef __CLIPPER__
     FREELIB32( hLib )
   #else
     FREELIBRARY( hLib )
   #endif

RETURN (lOk)


/*
Bingo! You can convert your bitmap to 24 bit using:

FUNCTION FISAVEIMG( cSrcFile, cDstFile, nDstFormat )

    LOCAL nSrcFormat, hDib, hDib2, lOk

#ifdef __CLIPPER__
    hLib = LOADLIB32( "freeimage.dll" )
#else
    hLib = LOADLIBRARY( "freeimage.dll" )
#endif

    nSrcFormat = FIGETFILETYPE( cSrcFile, 0 )

    hDib = FILOAD( nSrcFormat, cSrcFile, 0 )

    hDib2 = FICNV24( hDib )

    lOk = FISAVE( nDstFormat, hDib2, cDstFile, 0 )

    FIUNLOAD( hDib )
    FIUNLOAD( hDib2 )

#ifdef __CLIPPER__
    FREELIB32( hLib )
#else
    FREELIBRARY( hLib )
#endif

    RETURN lOk
*/

//---------------------------------------------------------------------------//
FUNCTION FIAdjustBright ( hDib, nBright )

  FIAdjustBrightness (hDib, nBright)

RETURN (nil)



FUNCTION FISize (cFile)

LOCAL nRet := 0, hDib, nFormat
LOCAL nWidth, nHeight

  hLib = LoadLibrary ( "freeimage.dll" )
  nFormat = FIGETFILETYPE( cFile, 0 )
  hDib := FILoad (nFormat,cFile,0)
  nHeight := FIGetHeight(hDib)
  nWidth := FIGetWidth (hDib)
  FIUnload (hDib)
  FreeLibrary ( hLib )

RETURN ({nWidth,nHeight})



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

DLL32 STATIC FUNCTION FIGETFILETYPE( cFileName AS LPSTR, nSize AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_GetFileType@8" LIB hLib

DLL32 STATIC FUNCTION FILOAD( nFormat AS LONG, cFileName AS LPSTR, nFlags AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_Load@12" LIB hLib

DLL32 STATIC FUNCTION FISAVE( nFormat AS LONG, hDib AS LONG, cFileName AS LPSTR, nFlags AS LONG ) AS BOOL;
      PASCAL FROM "_FreeImage_Save@16" LIB hLib

DLL32 STATIC FUNCTION FIUNLOAD( hDib AS LONG ) AS VOID;
      PASCAL FROM "_FreeImage_Unload@4" LIB hLib

DLL32 STATIC FUNCTION FIGETINFOHEADER( hDib AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_GetInfoHeader@4" LIB hLib

DLL32 STATIC FUNCTION FIGETINFO( hDib AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_GetInfo@4" LIB hLib

DLL32 STATIC FUNCTION FIGETBITS( hDib AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_GetBits@4" LIB hLib

DLL32 STATIC FUNCTION FICNV24( hDib AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_ConvertTo24Bits@4" LIB hLib

DLL32 STATIC FUNCTION FIADJUSTBRIGHTNESS( hDib AS LONG, nPercent AS _DOUBLE ) AS BOOL;
      PASCAL FROM "_FreeImage_AdjustBrightness@12" LIB hLib

DLL32 STATIC FUNCTION FIADJUSTContrast( hDib AS LONG, nPercent AS _DOUBLE ) AS BOOL;
      PASCAL FROM "_FreeImage_AdjustContrast@12" LIB hLib

DLL32 STATIC FUNCTION FIInitialise( lLoadPlug AS LONG) AS VOID;
      PASCAL FROM "_FreeImage_Initialise@4" LIB hLib

DLL32 STATIC FUNCTION FIDeInitialise(  ) AS VOID;
      PASCAL FROM "_FreeImage_DeInitialise@0" LIB hLib

DLL32 STATIC FUNCTION FIGetVersion (  ) AS LPSTR;
      PASCAL FROM "_FreeImage_GetVersion@0" LIB hLib

DLL32 STATIC FUNCTION FIGetCopyright (  ) AS LPSTR;
      PASCAL FROM "_FreeImage_GetCopyrightMessage@0" LIB hLib

DLL32 STATIC FUNCTION FIGetWidth ( hDib AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_GetWidth@4" LIB hLib

DLL32 STATIC FUNCTION FIGetHeight ( hDib AS LONG ) AS LONG;
      PASCAL FROM "_FreeImage_GetHeight@4" LIB hLib

DLL32 STATIC FUNCTION FIRotate ( hDib AS LONG, nAngle AS _DOUBLE ) AS LONG;
      PASCAL FROM "_FreeImage_RotateClassic@12" LIB hLib

DLL32 STATIC FUNCTION FIRotateEX ( hDib AS LONG, nAngle AS _DOUBLE, x_Shift AS _DOUBLE,y_Shift AS _DOUBLE,;
                                   x_Orig AS _DOUBLE, y_Orig AS _DOUBLE, lMask AS BOOL ) AS LONG;
      PASCAL FROM "_FreeImage_RotateEx@48" LIB hLib

DLL32 STATIC FUNCTION GETDC32( hWnd AS LONG ) AS LONG;
      PASCAL FROM "GetDC" LIB "user32.dll"

DLL32 STATIC FUNCTION RELEASEDC32( hWnd AS LONG ) AS LONG;
      PASCAL FROM "ReleaseDC" LIB "user32.dll"

DLL32 STATIC FUNCTION CREATEDIBITMAP( hDC AS LONG, hInfoH AS LONG, nFlags AS LONG, hBits AS LONG, hInfo AS LONG, nUsage AS LONG ) AS LONG;
      PASCAL FROM "CreateDIBitmap" LIB "gdi32.dll"
//----------------------------------------------------------------------------//

Re: Errsysw Visual Update ?

Posted: Tue Oct 18, 2011 7:27 pm
by Gale FORd
Thanks,

Since I left that request, I found most of what I needed.
I like this ErrSysW as a replacement.

I did make a few changes though.
Changed it so that English or German on the buttons and other places that were hard coded German before.
I also replaces some routines that are built into Fivewin now like FIConvertImageFile()
I also added the image as an attachment to the email.

Re: Errsysw Visual Update ?

Posted: Wed Oct 19, 2011 7:49 am
by yeangpumpeng
want to post a screenshot ?

Re: Errsysw Visual Update ?

Posted: Wed Oct 19, 2011 11:17 am
by StefanHaupt
Gale,

very good news :D

Maybe we had to compare the errorhandler, too, to see if something has changed in the last four years. These functions are new and have to be impelemented to get full compatibility: SetErrorPath(), SetErrorFileName() and SetPostErrorAction().

If you post the changed source, I can do this.

Re: Errsysw Visual Update ?

Posted: Wed Oct 19, 2011 4:42 pm
by Gale FORd
Here is my modified ErrSysW.prg

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 )
*/


Re: Errsysw Visual Update ?

Posted: Thu Oct 20, 2011 2:36 pm
by fespinoza
Gale

Very interesting your ErrSysW. I have a couple of concerns:

1) Could give more details on setting up to send email.
2) Could update the code to the latest version of FWH ErrSysW.prg.

Saludos

Fernando Espinoza

Re: Errsysw Visual Update ?

Posted: Thu Oct 20, 2011 10:12 pm
by Gale FORd
There are a couple of #defines in the ErrSysW.prg but usually you can just edit the email.ini that gets created the first time an error gets emailed.
In order to send the email you need a minimum of 4 things:
Login, Pass, Smtp-Host, and MailTo

Login = username to log into mail server.
Pass = password to use along with username
Smtp-Host = address of the Smtp mail server
MailTo = address you want to send the error email to

Because of security and other issues, you may have to provide more information.
Does you server require Pop before login to Smtp?
Can you relay through you server? If not then the Login may need to be the same as the ReplyTo (From).


This is the contents of my email.ini (with wrong password :) )

[Email]
User=
Login=Web@wwrowland.com
Pass=mypassword
Pop-Host=mail.wwrowland.com
Smpt-Host=mail.wwrowland.com
Leasedline=.F.
Autosave=.T.
Maildelete=.T.
ReplyTo=
MailTo=help.desk@wwrowland.com

Re: Errsysw Visual Update ?

Posted: Fri Oct 21, 2011 9:56 am
by StefanHaupt
Antonio,

I have included the last changes from fwh1109, so it should be compatible now. May I publish the the missing functions I included from fwh 1109 ?

Here is a screenshot from the errordialog

Image

You can view all errors ever occured from the database

Image

Re: Errsysw Visual Update ?

Posted: Fri Oct 21, 2011 10:04 am
by StefanHaupt
BTW, I need some help to include more languages in this error handler. At the moment we have german and english.
I would be happy, if someone can translate it into spanish, portuguese and other languages

Code: Select all

     #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 _SPANISH
    #endif

    #ifdef _PORTUG
    #endif

    #ifdef _ITALIAN
    #endif
   
Thanks :)