FiveTech Support Forums

// Error handler system adapted to FiveWin
// ErrSysW.prg

#include "error.ch"
#include "FiveWin.ch"

external _fwGenError   // Link FiveWin generic Error Objects Generator

#define NTRIM(n)    ( LTrim( Str( n ) ) )

#ifdef __HARBOUR__
    #define DLG_TITLE "Message"
    #command QUIT => ( PostQuitMessage( 0 ), __Quit() )
#endif

/*************
*   ErrorSys()
*
*   Note:  automatically executes at startup
*/
proc ErrorSys()
    ErrorBlock( { | e | ErrorDialog( e ) } )
return

proc ErrorLink()
return

/*************
*   ErrorDialog()
*/
static function ErrorDialog( e ) // -> logical or quits App.

local oDlg, oLbx, oFont, oFont1
local lRet    // if lRet == nil -> default action: QUIT
local n, j, cMessage, aStack := {}
local oSay, hLogo
local nButtons  := 1
local cErrorLog := ""
local aVersions := GetVersion()
local aTasks
local aRDDs, nTarget, uValue
local oOldError, c_pfad, cerr, cerr1, cerr2, cerr3, i, xxx, x
local cRelation, lNetOpt
local lIsWinNT := IsWinNT()

// by default, division by zero yields zero
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.       // Warning: Exiting!
endif

// 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"
    CLOSE ALL       
   SET RESOURCES TO
   ErrorLevel( 1 )
   QUIT
endif

ErrorBlock( {|e| MsgStop( ErrorMessage(e) + " from Errorsys, Line :" + ;
                         Str( ProcLine(1), 3 ) ), __quit() } )   // 1

cErrorLog += "Application "+MEMVAR->cModule+" "+MEMVAR->cEXEVersion + CRLF
cErrorLog += "Customer : "+MEMVAR->Coname  + CRLF
cErrorLog += "User ID : "+MEMVAR->us_name + CRLF
cErrorLog += "Station ID : "+MEMVAR->Networks + CRLF
cErrorLog += "Path : "+MEMVAR->cPath + CRLF
cErrorLog += "RDD : "+MEMVAR->cRDD + CRLF

cErrorLog += "==========================" + CRLF

cErrorLog += "Path and name : " + GetModuleFileName( GetInstance() )

#ifdef __CLIPPER__
     cErrorLog += " (16 bits)" + CRLF
#else
      cErrorLog += " (32 bits)" + CRLF
#endif

cErrorLog += "Sizes : " + Transform( FSize( GetModuleFileName( ;
                      GetInstance() ) ), "9,999,999 bytes" ) + CRLF
#ifdef __CLIPPER__
      cErrorLog += "   Max files handles permited : ( SetHandleCount() ) " + ;
                            Str( SetHandleCount(), 3 ) + CRLF
#endif

cErrorLog += "Time from start : " + TimeFromStart() + CRLF

 cErrorLog += "Error occurred at : " + ;
                        DToC( Date() ) + ", " + Time() + CRLF

// Error object analysis
cMessage   = "Description : " + ErrorMessage( e ) + CRLF
cErrorLog += cMessage

if ValType( e:Args ) == "A"
      cErrorLog += "   Args:" + CRLF
      for n = 1 to Len( e:Args )
         cErrorLog += "     [" + Str( n, 4 ) + "] = " + ValType( e:Args[ n ] ) + ;
                                "   " + cValToChar( e:Args[ n ] ) + CRLF
      next
endif

cErrorLog += CRLF + "Stack Calls" + CRLF
cErrorLog += "==========================" + CRLF
n := 2    // we don't disscard any info again !
while ( n < 74 )
    if ! Empty(ProcName( n ) )
        AAdd( aStack, "   Called from : " + ProcFile( n ) + " => " + Trim( ProcName( n ) ) + ;
                        "(" + NTRIM( ProcLine( n ) ) + ")" )
        cErrorLog += ATail( aStack ) + CRLF
    endif
        n++
end

cErrorLog += CRLF + "System" + CRLF
cErrorLog += "======" + CRLF

#ifdef __CLIPPER__
      cErrorLog += "   CPU type: " + GetCPU() + CRLF
#else
      cErrorLog += "   CPU type: " + GetCPU() + " " + ;
                            AllTrim( Str( GetCPUSpeed() ) ) + " Mhz" + CRLF
#endif

cErrorLog += "   Hardware Memory: " + ;
                      cValToChar( Int( nExtMem() / ( 1024 * 1024 ) ) + 1 ) + ;
                       " megs" + CRLF + CRLF

cErrorLog += "   Free System-resources : " + AllTrim( Str( GetFreeSystemResources( 0 ) ) ) + " %" + CRLF + ;
                       "   GDI    resources : " + AllTrim( Str( GetFreeSystemResources( 1 ) ) ) + " %" + CRLF + ;
                       "   User   resources : " + AllTrim( Str( GetFreeSystemResources( 2 ) ) ) + " %" + CRLF + CRLF

cErrorLog += "   Compiler-version: " + Version() + CRLF

#ifdef __CLIPPER__
      cErrorLog += "   Windows and MsDos versions : " + ;
                   AllTrim( Str( aVersions[ 1 ] ) ) + "." + ;
                   AllTrim( Str( aVersions[ 2 ] ) ) + ", " + ;
                   AllTrim( Str( aVersions[ 3 ] ) ) + "." + ;
                   AllTrim( Str( aVersions[ 4 ] ) ) + CRLF + CRLF
#else
      cErrorLog += "   Windows-version: " + ;
                   AllTrim( Str( aVersions[ 1 ] ) ) + "." + ;
                   AllTrim( Str( aVersions[ 2 ] ) ) + ", Stand " + ;
                   AllTrim( Str( aVersions[ 3 ] ) ) + ;
                   " " + aVersions[ 5 ] + CRLF + CRLF
#endif

aTasks = GetTasks()
cErrorLog += "   Windows total applications running : " + ;
                        AllTrim( Str( Len( aTasks ) ) ) + CRLF
for n = 1 to Len( aTasks )
      cErrorLog += "    " + Str( n, 3 ) + " " + aTasks[ n ] + CRLF
next

// Warning!!! Keep here this code !!! Or we will be consuming GDI as
// we don't generate the error but we were generating the bitmap

if e:canRetry
      nButtons++
endif

if e:canDefault
      nButtons++
endif

cErrorLog += CRLF + "Variables in use " + CRLF + "====================" + CRLF
cErrorLog += "   Procedure     Type   Value" + CRLF
cErrorLog += "   ==========================" + CRLF

n := 2    // we don't disscard any info again !
while ( n < 74 )

       if ! Empty( ProcName( n ) )
        cErrorLog += "   " + Trim( ProcName( n ) ) + CRLF
        for j = 1 to ParamCount( n )
            cErrorLog += "     Param " + Str( j, 3 ) + ":    " + ;
                        ValType( GetParam( n, j ) ) + ;
                        "    " + cGetInfo( GetParam( n, j ) ) + CRLF
        next
        for j = 1 to LocalCount( n )
            cErrorLog += "     Local " + Str( j, 3 ) + ":    " + ;
                          ValType( GetLocal( n, j ) ) + ;
                        "    " + cGetInfo( GetLocal( n, j ) ) + CRLF
        next
       endif

       n++

end

cErrorLog += CRLF + "Linked RDDs" + CRLF + "=============" + CRLF
aRDDs = RddList( 1 )
for n = 1 to Len( aRDDs )
      cErrorLog += "   " + aRDDs[ n ] + CRLF
next

cErrorLog += CRLF + "DataBases in use  " + CRLF + "===================" + CRLF
for n = 1 to 255
    if !Empty( Alias( n ) )
        cErrorLog += CRLF + Str( n, 3 ) + ": " + If( Select() == n,"=> ", "   " ) + ;
                      PadR( Alias( n ), 15 ) + Space( 20 ) + "RddName: " + ;
                  ( Alias( n ) )->( RddName() ) + CRLF
        cErrorLog +=    "     ==============================" + CRLF
        cErrorLog +=    "     RecNo    RecCount    BOF   EOF" + CRLF
        cErrorLog +=    "    " + Transform( ( Alias( n ) )->( RecNo() ), "9999999" ) + ;
                            "      " + Transform( ( Alias( n ) )->( RecCount() ), "9999999" ) + ;
                        "      " + cValToChar( ( Alias( n ) )->( BoF() ) ) + ;
                    "   " + cValToChar( ( Alias( n ) )->( EoF() ) ) + CRLF + CRLF
                      
             if ( Alias( n ) )->( RddName() ) != "ARRAYRDD"             
            cErrorLog += "     Indexes in use " + Space( 23 ) + "TagName" + CRLF
            for j = 1 to 15
                if !Empty( ( Alias( n ) )->( IndexKey( j ) ) )
                    cErrorLog += Space( 8 ) + ;
                    If( ( Alias( n ) )->( IndexOrd() ) == j, "=> ", "   " ) + ;
                        PadR( ( Alias( n ) )->( IndexKey( j ) ), 35 ) + ;
                        ( Alias( n ) )->( OrdName( j ) ) + ;
                        CRLF
                endif
            next
            cErrorLog += CRLF + "     Relations in use : " + CRLF
            for j = 1 to 8
                if !Empty( ( nTarget := ( Alias( n ) )->( DbRSelect( j ) ) ) )
                    cErrorLog += Space( 8 ) + Str( j ) + ": " + ;
                    "TO " + ( Alias( n ) )->( DbRelation( j ) ) + ;
                    " INTO " + Alias( nTarget ) + CRLF
                    // uValue = ( Alias( n ) )->( DbRelation( j ) )
                    // cErrorLog += cValToChar( &( uValue ) ) + CRLF
                endif
            next
        endif
    endif
next

n = 1
cErrorLog += CRLF + "Classes in use :" + CRLF
cErrorLog += "==================" + CRLF
   
#ifndef __XHARBOUR__
    while ! Empty( __ClassName( n ) )
        cErrorLog += "   " + Str( n, 3 ) + " " + __ClassName( n++ ) + CRLF
    end
#else   
    while n <= __ClsCntClasses()
        cErrorLog += "   " + Str( n, 3 ) + " " + __ClassName( n++ ) + CRLF
    end
#endif   

cErrorLog += CRLF + "Memory Analysis" + CRLF
cErrorLog +=        "================" + CRLF

#ifdef __CLIPPER__
      cErrorLog += "   Static memory :" + CRLF
      cErrorLog += "      Data Segment : 64k" + CRLF
#endif

#ifdef __CLIPPER__
    cErrorLog += "      Initial size :       " + ;
                LTrim( Str( nInitDSSize() ) ) + ;
                " bytes  (SYMP=" + LTrim( Str( nSymPSize() ) ) + ;
                ", Stack=" + LTrim( Str( nStackSize() ) ) + ;
                ", Heap=" + LTrim( Str( nHeapSize() ) ) + ")" + CRLF
    cErrorLog += "      PRG Stack:          " + ;
                LTrim( Str( 65535 - ( nStatics() * 14 ) - nInitDSSize() ) ) + ;
                " bytes" + CRLF
#endif

#ifdef __CLIPPER__
    cErrorLog += "      " + LTrim( Str( nStatics() ) ) + " Static variables : " + ;
                   LTrim( Str( nStatics() * 14 ) ) + " bytes" + CRLF + CRLF
#else
    cErrorLog += "      " + LTrim( Str( nStatics() ) ) + " Static variables" + ;
                   CRLF + CRLF
#endif

cErrorLog += "   Dynamic memory consume :" + CRLF
cErrorLog += "      Actual  Value : " + Str( MemUsed() ) + " bytes" + CRLF
cErrorLog += "      Highest Value : " + Str( MemMax() ) + " bytes" + CRLF
// nSymNames() no longer returns a real value! 15/April/97
/*
cErrorLog += "   SYMBOLS segment" + CRLF
cErrorLog += "      " + LTrim( Str( nSymNames() ) ) + " SymbolNames:   " + ;
                    LTrim( Str( nSymNames() * 16 ) ) + " bytes"
*/

// you can save max 10 Error-messages
// then it starts with 1 again
//  -------------------------                                       programm-name
// c_dir    := GetModuleFilename(GetInstance(),"BOS32.EXE" + CHR(0), 255)
// c_pfad   := left ( c_dir, rat( "\", c_dir) -1 )
// c_pfad   = Path of application
c_pfad := MEMVAR->cPath+'LOG'
if !lIsDir(MEMVAR->cPath+'LOG')
   lMkDir(MEMVAR->cPath+'LOG')
end

cERR := ""
cERR1 := ""
n := 0
BEGIN SEQUENCE
    
    oOldError = ErrorBlock( { || DoBreak() } )

    // ------------- NEW --------------------------------------

    i := 0
    do while i <= 100
        i++
        xxx := strzero(i,2)
        cERR   := c_pfad+"\LOGER_" + xxx + ".LOG"
        if !File(cERR) .or. i = 100
            // deletes the old error.log`s
            // ---------------------------------
            IF i = 100
                cERR := c_pfad+"\LOGER_01.LOG"
                x := 1
                FOR x := 1 TO 99
                    xxx     := strzero(x,2)
                    cERR1 := c_pfad+"\LOGER_" + xxx + ".LOG"
                    DELETE FILE &cERR1
                NEXT    
               MemoWrit( cERR, cErrorLog )
                EXIT
            ELSE
               IF !FILE( cERR )
                    MemoWrit( cERR, cErrorLog )
                    EXIT
                ENDIF
            ENDIF
        ENDIF
    end
    cERR3 := c_pfad+"\LOGER_" + xxx + ".LOG"
    cERR2 := "LOGER_" + xxx + ".LOG"

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

END SEQUENCE
ErrorBlock( oOldError )

lNetOpt := IsInternet()

if lNetOpt
    // SendLog( cERR3 )
end

DEFINE FONT oFont NAME "Arial" SIZE -6, 0 

DEFINE DIALOG oDlg TITLE DLG_TITLE SIZE 600, 130 FONT oFont

    @ 7, 0 SAY oSay PROMPT OemToAnsi( cMessage ) ;
    CENTERED OF oDlg FONT oFont SIZE 300, 20 PIXEL
    
    oSay:nStyle   = nOR( oSay:nStyle, 128 )   // SS_NOPREFIX
    
    n = aStack[ 1 ]
    
    @ 20, 20 BUTTON "View Log file" OF oDlg FONT oFont ;
                SIZE 80, 12 PIXEL ;
                ACTION WinExec( "Notepad.exe "+cERR3 )
    if lNetOpt
    @ 20,110 BUTTON "Email to Support" OF oDlg FONT oFont ;
                SIZE 80, 12 PIXEL ;
                ACTION (SendLog( cERR3 ), oDlg:End())
    end
    @ 20,200 BUTTON "E&xit" OF oDlg FONT oFont ;
            SIZE 80, 12 PIXEL ;
            ACTION oDlg:End() ;
            DEFAULT
    
    // Here you can write a message what to do with the ERROR1 - 30.log
    @ 38,  10 SAY "Please contact EASYFO Support and send log file <"+cERR2+">" OF oDlg FONT oFont PIXEL SIZE 280, 12 CENTERED
    @ 50,  10 SAY MEMVAR->cContInfo OF oDlg FONT oFont1 PIXEL SIZE 280, 12 CENTERED

ACTIVATE DIALOG oDlg CENTERED 

if lRet == nil .or. ( !LWRunning() .and. lRet )
      SET RESOURCES TO
      ErrorLevel( 1 )
      CLOSE ALL
      QUIT              // must be QUIT !!!
endif

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
endif

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


*--------------------------------------------*
Static Function SendLog( cFileName, lNoMsg )
local mDlg, oSay, oGet[4], oBtn[2]
local lOk := .F., lStart := .T.
local cAtt, cSub, cText, cTo, cSender, cPass, cDisplay, cReply, lSave
local cFile

Default lNoMsg := .F.

if IsInternet()
    cFile := ''
    if file( cFileName )
        cAtt := cFileName
        cFile:= subs(cFileName,at('.LOG',cFileName)-8,12)
    else
    lStart := .F.
       MsgAlert('Log File is missing, Cannot Send now!')
    end

    if lStart

    cPass       := 'password'
    cDisplay    := '(EASYFO support)'
    cSender := <!-- e --><a href="mailto:'myemail@gmail.com">'myemail@gmail.com</a><!-- e -->'
    cReply  := <!-- e --><a href="mailto:'myemail@gmail.com">'myemail@gmail.com</a><!-- e -->'
    
      cSub      := left('Send Log File : '+cFile+' from '+rtrim(MEMVAR->coname)+space(100),100)
       cTo      := left(MEMVAR->cMailSupport+space(100),100)
      lSave     := .T.

       if file( cAtt )
   
        MsgRun("This messages is sending now",;
                "E-mail is sending, please wait...",;
              { | oDlg | UpCaption( oDlg, cSender, cPass, cDisplay, cReply, lSave, rtrim(cTo), cSub, cAtt, cSub ) } )
             
       end            
    end
else

   MsgStop('Please check your internet connection before use')

end
return nil           
            
*---------------------------------------------------------------------------------------------------*            
Static function UpCaption( oDlg, cSender, cPass, cDisplay, cReply, lSave, cTo, cSubject, cAtt, cMsg )            
local n, lMsgInfo, cCC := ''

lMsgInfo := .F.

SendMail( oDlg, cSender, cPass, cDisplay, cReply, lSave, cTo, cCC, cSubject, cMsg, .F., cAtt, .T. )
oDlg:cMsg := "The messages have sent successfully "
oDlg:Refresh()
SysRefresh()

return nil 


**************************************************************
*****  New SendMail by GMail
**************************************************************
*-------------------------------------------------------------------------------------------------------------------------------*
Static Function SendMail( oDlg, cSender, cPass, cDisplay, cReply, lSave, cTo, cCC, cSubject, cMsg, lReceipt, cAttach, lMsgInfo, cGstNo )
*-------------------------------------------------------------------------------------------------------------------------------*
Local oEmailCfg,oEmailMsg,oError,cHtml, cLine, n
local nSuccess 

nSuccess := 1

Default lReceipt := .T., lMsgInfo := .F., lSave := .T., cAttach := '', cSubject := '', cDisplay := MEMVAR->coname, cMsg := '', cCC := '', ;
          cReply := cSender, cGstNo := ''

cMsg := alltrim(cMsg)

CursorWait()

cHtml:='<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN">'
cHtml+='<HTML><HEAD>'
cHtml+='<META content="text/html; charset=windows-874" http-equiv=Content-Type>'
cHtml+='<META name=GENERATOR content="MSHTML 8.00.6001.18783">'
cHtml+='<STYLE></STYLE>'
cHtml+='</HEAD>'
cHtml+='<BODY bgColor=#ffffff>'
cHtml+='<DIV>'

// cHtml += '<DIV><FONT size=2 color=blue face=Arial>Hello How are you ?</FONT></DIV></BODY></HTML>'

// cHtml += cMsg

for n := 1 to MLCount( cMsg )
     cLine := rtrim(memoline( cMsg, 100, n ))
     cHtml += cLine+"<br>"  // HB_readline( cMsg )
next

cHtml+='</DIV></BODY></HTML>'

TRY
  oEmailCfg := CREATEOBJECT( "CDO.Configuration" )
  WITH OBJECT oEmailCfg:Fields
     :Item( "http://schemas.microsoft.com/cdo/configuration/smtpserver" ):Value                 := "smtp.gmail.com"
     :Item( "http://schemas.microsoft.com/cdo/configuration/smtpserverport" ):Value         := 465
     :Item( "http://schemas.microsoft.com/cdo/configuration/sendusing" ):Value              := 2   // Remote SMTP = 2, local = 1
     :Item( "http://schemas.microsoft.com/cdo/configuration/smtpauthenticate" ):Value       := .T.
     :Item( "http://schemas.microsoft.com/cdo/configuration/smtpusessl" ):Value                 := .T.
     :Item( "http://schemas.microsoft.com/cdo/configuration/savesentitems" ):Value          := lSave
     :Item( "http://schemas.microsoft.com/cdo/configuration/sendusername" ):Value           := cSender  //  "hotel@gmail.com"
     :Item( "http://schemas.microsoft.com/cdo/configuration/sendpassword" ):Value           := cPass // Password
     :Item( "http://schemas.microsoft.com/cdo/configuration/smtpconnectiontimeout"):Value := 60
     :Update()
  END WITH

CATCH oError
    if lMsgInfo
        MsgAlert("Could not send message" +CRLF+  ;
            "Error: " + TRANSFORM(oError:GenCode, NIL) +CRLF+  ;
            "SubC: " + TRANSFORM(oError:SubCode, NIL) +CRLF+  ;
                "OSCode: " + TRANSFORM(oError:OsCode, NIL) +CRLF+  ;
                "SubSystem: " + TRANSFORM(oError:SubSystem, NIL) +CRLF+  ;
                "Message: " + oError:Description )
    else
    nSuccess := 0
    end

END
oError:=NIL

TRY
    oEmailMsg := CREATEOBJECT ( "CDO.Message" )
    WITH OBJECT oEmailMsg
        :Configuration  := oEmailCfg
        :From               := chr(34)+cDisplay+" "+chr(34)+ "<"+cReply+">" // cSender  // This will be displayed in the From (The email id does not appear)
        :To                 := cTo   // "dutch@easyfo.com"    // <-----   Place your email address
        :Subject            := cSubject  //   "Email Test Message from GMail"
        :ReplyTo            := cReply
        :MDNRequested   := .F.
        if !empty(cAttach)
              :AddAttachment(cAttach)
        end
        :HTMLBody = cHtml
    END WITH
    oEmailMsg:Send()
CATCH oError
    if lMsgInfo
       MsgAlert("Could not send message" + ";"  + CRLF+ ;
             "Error: " + TRANSFORM(oError:GenCode, NIL) + ";" + CRLF+;
              "SubC: "  + TRANSFORM(oError:SubCode, NIL) + ";" + CRLF+ ;
               "OSCode: "+ TRANSFORM(oError:OsCode, NIL) + ";" + CRLF +;
                "SubSystem: " + TRANSFORM(oError:SubSystem, NIL) + ";" +CRLF+ ;
                "Message: " + oError:Description )
    else
    nSuccess := 0
    end

END

CursorArrow()

Return nSuccess




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

#define  HKEY_LOCAL_MACHINE  2147483650  // 0x80000002

*---------------*
function GetCPU()

local oReg := TReg32():New( HKEY_LOCAL_MACHINE,;
                       "HARDWARE\DESCRIPTION\System\CentralProcessor\0",;
                               .f. )
local cCpu := oReg:Get( "ProcessorNameString" )

oReg:Close()

return cCpu

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

#ifdef __HARBOUR__
    #ifndef __XHARBOUR__
        REQUEST HB_GT_GUI
        procedure HB_GTSYS() ; return
        procedure HB_GT_GUI_DEFAULT() ; return 
        procedure FW_GT ; return
    #endif    
#endif   

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

*-------------------------------------------*
Procedure FlrDesign(oBrw,cTitle,cBmpFile,FLR)
local oDlg, oBtn
local n, nWndWidth, nWndHeight
local nResScr := iif(GetSysMetrics(0)=1024,10,iif(GetSysMetrics(0)=800,8,12))
local RMS

oBtn := {}

RMS := OPENDB('foroom',,'rms_floor="'+FLR:flr_flrno+'"','rms_floor')

nWndWidth  := val(alltrim(Str(GetSysMetrics(0)))) - 8  
nWndHeight := ((GetWndRect( GetWndApp() )[3] + GetWndRect( GetWndApp() )[1]) - 60)


   DEFINE DIALOG oDlg FROM  0, 0 TO nWndHeight, nWndWidth PIXEL TITLE rtrim(cTitle) FONT MEMVAR->oFont  ;
                      COLOR CLR_BLACK, CLR_WHITE

      oDlg:lHelpIcon := .F.
                            
//    @  0, MEMVAR->LeftWin/2 BITMAP oBmp FILENAME (MEMVAR->cBmpPath+cBmpFile) OF oDlg ;
      @  0, MEMVAR->LeftWin/2 XIMAGE oBmp SOURCE MEMVAR->FLR:flr_image OF oDlg ;
                                    SIZE (nWndWidth/2)-42, (nWndHeight/2)-10  

      oBmp:bMouseWheel := { || .T. }

   ACTIVATE DIALOG oDlg RESIZE16 ;
                            ON PAINT (ShowBtn(@oBtn,oDlg,oBmp,nResScr,RMS,FLR)) ;
                            VALID    (SaveRowCol(aRms,oBtn,RMS)) 
    
   // PalBmpFree( oBmp:hBitMap )

CLOSEDB(RMS)
return

*------------------------------------------------*
Function ShowBtn( oBtn,oDlg,oBmp,nResScr,RMS,FLR)
local n
aRms := {}

RMS:GoTop()
if RMS:Keycount() > 0
   do while RMS:rms_floor = FLR:flr_flrno .and. !RMS:eof()
      if left(RMS:rms_rmty,1)  <> 'H'
         do case 
            case nResScr = 10
                  aadd( aRms , { RMS:rms_rmno , RMS:rms_row*2  , RMS:rms_col*2   } )
            case nResScr = 8
                  aadd( aRms , { RMS:rms_rmno , RMS:rms_row8*2 , RMS:rms_col8*2  } )
            otherwise
                 aadd( aRms , { RMS:rms_rmno , RMS:rms_row12*2, RMS:rms_col12*2 } )
         endcase              
      end
      RMS:skip()
   end
end

oBtn := array(len(aRms))
for n := 1 to len(aRms)
    MakeBtn(n,oBtn,oDlg,oBmp,nResScr)
next
return nil

*---------------------------------*
Function SaveRowCol(aRms,aBtn,RMS)
local n
local nResScr := iif(GetSysMetrics(0)=1024,10,iif(GetSysMetrics(0)=800,8,12))

RMS:GoTop()
do while !RMS:eof()
    if (n := ascan( aRms, {|x| x[1]=RMS:RMS_RMNO } )) > 0
       do case
          case nResScr = 10
                RMS:rms_row   := (aBtn[n]:nTop/2)
                RMS:rms_col   := (aBtn[n]:nLeft/2)
             case nResScr = 8
                RMS:rms_row8  := (aBtn[n]:nTop/2)
                RMS:rms_col8  := (aBtn[n]:nLeft/2)
          otherwise
                RMS:rms_row12 := (aBtn[n]:nTop/2)
                RMS:rms_col12 := (aBtn[n]:nLeft/2)
       end
    end
    RMS:Save()
    RMS:Skip()
end
return .T.

*-------------------------------------------------*
Static Procedure MakeBtn(n,oBtn,oDlgs,oBmp,nResScr)
local nWidth, nHeight

if nBtn2W = 0
    nWidth  := ( iif(nResScr=8,17,iif(nResScr=10,18,20)) * 2 )
    nHeight := ( iif(nResScr=8,17,iif(nResScr=10,18,22)) * 2 )
else
    nWidth  := nBtn2W * 2
    nHeight := nBtn2H * 2
end

@ aRms[n][2], aRms[n][3] SBUTTON oBtn[n] ;
              PROMPT aRms[n][1] ;
              SIZE nWidth, nHeight ;
              PIXEL ;
              OF oBmp ; //              
              RECT ;
              COLOR {|oBtn| If( oBtn:lMouseOver, CLR_YELLOW, CLR_BLACK ) },  CLR_WHITE
              
oBtn[n]:lDrag := .T.              
              
return

SetErrorDialog( bOwnDialg ) --> bPrevious