ON ERROR DO fShowError

FUNCTION fShowError()
MESSAGEBOX("Error...")
fQuit()

FUNCTION fQuit()
ON ERROR *
ON SHUTDOWN
nForm=_Screen.FormCount
FOR iForm=1 to nForm
    oForm=_Screen.Forms(iForm)
    WITH oForm
         .Closable=.T.
         .Release()
    ENDWITH
NEXT
CLOSE TABLES
CLEAR ALL
CLEAR PROGRAM
CLOSE ALL
CLEAR EVENTS
QUIT

ON ERROR *

DO FORM MainForm
READ EVENTS
CLOSE TABLES
RELEASE ALL EXTENDED
CLEAR EVENTS
QUIT

FUNCTION fQuit()  
ON ERROR *  
ON SHUTDOWN fQuit()      && !!
nForm=_Screen.FormCount  
FOR iForm=1 to nForm  
    oForm=_Screen.Forms(iForm)  
    WITH oForm  
         .Closable=.T.  
         .Release()  
    ENDWITH  
NEXT  
CLOSE TABLES  
CLEAR ALL  
CLEAR PROGRAM  
CLOSE ALL  
CLEAR EVENTS 
CREATE CURSOR A (A c(1)) && !!
ON ERROR CANCEL          && !!
QUIT

#DEFINE _lf CHR(13)+CHR(10)
****************
PROCEDURE MError
****************
PARAMETERS    m.cod, ;
            m.mess,;
            m.prg, ; 
            m.lin,;
            m.mess1


IF SET('ESCAPE') = 'ON'
        SET ESCAPE OFF
        STORE 'ON' TO m.esc_set
    ELSE
        STORE 'OFF' TO m.esc_set
ENDIF


_i = 1
m.chain = ''
DO WHILE LEN(PROGRAM(_i)) <> 0
    m.chain = m.chain + ' -> ' + PROGRAM(_i)
    _i = _i + 2
ENDDO

**********************************************************************
**   Запрос на откат транзакции:
**********************************************************************
If type("oServer")="O" 
    local llSuccessTestConnection
    try
        llSuccessTestConnection = (oServer.sqlexec('select 1') > 0)
    catch
    endtry
    use in select("sqlResult")    
    if llSuccessTestConnection
        lnTrancount = oServer.sqlReturn("select @@trancount")
        If lnTrancount > 0
            If MessageBox("Существуют незавершенные транзакции! Откатить транзакции?",4+32,"Внимание")=6
                oServer.sqlexec("if @@trancount > 0 rollback transaction")
            else
                oServer.sqlexec("while @@trancount > 0 commit transaction")
            endif
        endif
    endif
endif

**********************************************************************
**   Сообщения о следующих ошибках в базе errorinf.DBF не фиксируем:
**   1707    Structural CDX file not found.
**    221    Left margin plus indent must be less than right margin.
**********************************************************************
IF !(m.cod = 1707 OR m.cod = 221)
    =ErrToDbf(m.prg, m.cod, m.mess, m.lin, m.mess1, m.chain)
ENDIF

**************************** Создание окна сообщения *****************

lcText     = ""
lcText1 = ""        
lcText2 = ""
lcText3 = ""
lcText4 = ""
lbWhatShow = 1
lbVisible = 3

DO CASE

    CASE m.cod = 108 OR m.cod = 1705 
        DO CASE
            CASE m.Cod = 108
                lcText = '    Файл БД открыт другим пользователем. Дождитесь, пока файл не освободится.' 

            CASE m.Cod = 1705
                lcText = '    Или файл открыт другим пользователем или у ВАС недостаточно прав для создания файлов на сетевом диске.' 

        ENDCASE
        
    CASE m.cod = 26 OR 'Database is not ordered.' $ m.mess OR m.cod = 114 ;
                OR 'Index does not match database file.' $ m.mess

        m.temp = DBF()
        m.temp = LEFT(m.temp, LEN(m.temp) - 4) + '.CDX'
        lcText = '    Индексный файл ' + m.temp + ' отсутствует или разрушен. Выполните процедуру индексации.'


    CASE m.cod = 1102 OR 'Cannot create file.' $ m.mess
        lcText = 'Неудачная попытка создания файла. Возможно на диске больше нет места или у ВАС нет прав для создания файлов на сетевом диске.'


    CASE m.cod = 1157 OR m.cod = 1160 OR 'Not enough disk space' $ m.mess
        lcText = 'На диске нет места для продолжения работы. Также возможен сбой диска'


    CASE m.cod = 1410 OR 'Unable to create temporary work file(s).' $ m.mess
        lcText = 'FoxPro не может создать временный файл для работы. Диск может быть полон. Или у ВАС нет прав для создания файлов на сетевом диске.'

    CASE m.cod = 15 OR 'Not a database file.' $ m.mess
        lcText = 'Файл  ' + SUBSTR(DBF(),3) + '  поврежден. Выполните программу ремонта.'

    OTHERWISE
        lbWhatShow = 2
        lcText = ""
        lcText1 = prg         
        lcText2 = LTRIM(STR(m.cod)) 
        lcText3 = m.mess 
        lcText4 = LTRIM(STR(lin))
        lbVisible = 7
endcase

local lnRes
lnRes = 0

IF m.cod = 1707 && Игонорируем и выполняем заново (CDX file is not found)
    lnRes = 3
ELSE
    IF     m.cod = 221 OR m.cod = 55 OR m.cod = 1642
        lnRes = 2
    ELSE
        DO FORM ERR_FORM WITH lbWhatShow,;
                              lcText,      ;
                              lcText1,      ;
                              lcText2,      ;
                              lcText3,      ;
                              lcText4,      ;
                              lbVisible, ;
                              m.mess1 TO lnRes
    ENDIF
ENDIF


************************* Обработка событий нажатия кнопок ************************
DO CASE
    CASE lnRes = 1  && Главное меню
        ReturnCalledProgramm()

    CASE lnRes = 2 && Игнорировать
        ON ESCAPE
        SET ESCAPE &esc_set
        SET CONSOLE OFF
        ON ERROR DO merror ;
            WITH ERROR(), MESSAGE(), PROGRAM(), LINENO(1), MESSAGE(1)

    CASE lnRes = 3 
        ON ESCAPE
        SET ESCAPE &esc_set
        ON ERROR DO merror ;
            WITH ERROR(), MESSAGE(), PROGRAM(), LINENO(1), MESSAGE(1)
        RETRY
        RETURN


    OTHERWISE
        ReturnCalledProgramm()

ENDCASE

RETURN 1




********************************
FUNCTION    ReturnCalledProgramm
********************************

CLEAR GETS
SET DEVICE TO SCREEN 
ON ESCAPE
SET ESCAPE &esc_set
SET CURSOR ON
ON KEY LABEL F2
ON KEY LABEL F3
ON KEY LABEL F4
ON KEY LABEL F5
ON KEY LABEL F6
ON KEY LABEL F7
ON KEY LABEL F8
ON KEY LABEL F9
ON KEY LABEL ENTER
ON KEY LABEL INS
ON KEY LABEL TAB
ON KEY LABEL BACKTAB
ON KEY LABEL ESC
ON ERROR DO merror ;
            WITH ERROR(), MESSAGE(), PROGRAM(), LINENO(1), MESSAGE(1)

*** Закрываем все окна приложения
e_nFormCount    = _SCREEN.FORMCOUNT
FOR e_nNum = e_nFormCount TO 1 STEP -1
    IF !(UPPER(ALLT(_SCREEN.FORMS(e_nNum).NAME)) == "G_GROUP_DOC")
        _SCREEN.FORMS(e_nNUm).LockScreen = .F.
        _SCREEN.FORMS(e_nNum).VISIBLE    = .F.
        _SCREEN.FORMS(e_nNum).RELEASE ()
    ENDIF
ENDFOR

IF TYPE("pcMenu_Name") # "C" 
    SET SKIP OF MENU  main_menu .F.
ELSE
    SET SKIP OF MENU &pcMenu_Name .F.
ENDIF

RETURN TO main_pr2




********************
FUNCTION    ErrToDbf
********************
PARAMETERS    m.prg, m.cod, m.mess, m.lin, m.mess1, m.chain
return
PRIVATE        m.savealias

m.savealias = ALIAS()


* Переделана работа с файлом errorinf 
* проверяем предварительно есть ли атрибут "Только для чтения" и сбрасываем его, если есть 
IF NOT FILE('errorinf.DBF')
  CREATE DBF errorinf ( ;
                program  C (  8), ;
                chain    C ( 80), ;
                errorno  N (  6), ;
                errormsg C ( 80), ;
                lineno   N (  6), ;
                badcode  C (128), ;
                alias    C (  8), ;
                date     D (  8), ;
                time     C (  5)  )
ENDIF  
        
USE IN select("errorinf")
        
IF ADIR(_laFiles,'errorinf.dbf') > 0 
   IF  "R" $ _laFiles[1,5] && файл имеет признак ReadOnly, пробуем его убрать

        DECLARE INTEGER SetFileAttributes IN win32api STRING, INTEGER
      =SetFileAttributes('errorinf.dbf',128)    && 0x00000080
      *   IF SetFileAttributes('errorinf.dbf',128)=0    && 0x00000080 - не удалось убрать файл
            
   ENDIF  
ENDIF 

* Открываем файл
USE errorinf in 0


APPEND BLANK
REPLACE NEXT 1 ;
    program  WITH m.prg      , ;
    chain    WITH m.chain   , ;
    errorno  WITH m.cod      , ;
    errormsg WITH m.mess     , ;
    lineno   WITH m.lin      , ;
    badcode  WITH m.mess1    , ;
    alias    WITH m.savealias, ;
    date     WITH DATE()   , ;
    time     WITH SUBSTR(TIME(),1,5)

use in select("errorinf")

IF NOT EMPTY(m.savealias)
    SELECT (m.savealias)
endif

return 

LPARAMETERS bWhatShow,;                && Что показывать 1 - СООБЩЕНИЕ 2 - ошибку программы
            cTextMessage,;            && Текст сообщения
            cText1,;
            cText2,;
            cText3,;
            cText4,;
            bBitVisibleButtons,;     && Битовая маска визуализации кнопок
            cText5                    && строка программы

WITH THISFORM
    
    .displayMemo()
    .checkStack()
    
    wait clear    

    LOCAL cStr, cBuff, nFHandle

    IF !empty(bWhatShow) and bWhatShow = 1
        * вывод сообщения
        cStr =  iif(vartype(cTextMessage)="C", cTextMessage, "")
        
        store .f. to .Acommandbutton1.visible, ;
                     .Acommandbutton3.visible, ;
                     .DebugCommand.visible 
        store .t. to .cmdOk.Visible
    ELSE
        * сообщение по параметрам
        cStr =  "Модуль: "            +alltrim(iif(vartype(cText1)="C",cText1,""))+CHR(13)+;
                "Номер ошибки: "    +alltrim(iif(vartype(cText1)="C",cText2,""))+CHR(13)+;
                "Сообщение: "        +alltrim(iif(vartype(cText1)="C",cText3,""))+CHR(13)+;
                "Номер строки: "    +alltrim(iif(vartype(cText1)="C",cText4,""))+CHR(13)+;
                "Строка программы: "+alltrim(iif(vartype(cText1)="C",cText5,""))
        * если есть файл с ошибками показываем его
        IF FILE("c_debug.log",1)
            nFHandle = FOPEN("c_debug.log")
            IF nFHandle>0
                cBuff = FREAD(nFHandle,1024*32)
                IF !EMPTY(cBuff)
                    cStr = cBuff
                ENDIF
                =FCLOSE(nFHandle)
            ENDIF
        ENDIF

        bBitVisibleButtons = iif(vartype(bBitVisibleButtons)<>"N",0,bBitVisibleButtons)
        .Acommandbutton1.Enabled = BITTEST(bBitVisibleButtons,0)
        *.Acommandbutton2.Enabled = BITTEST(bBitVisibleButtons,1)
        .Acommandbutton3.Enabled = BITTEST(bBitVisibleButtons,2)
        .DebugCommand.visible = (version(2)=2)

            
    endif
    
    this.pf1.page1.AeditBox1.Value = cStr   

    .Resizer1.Get_sizes()
    *.Left     = 50
    *.Top     = 50
    .Caption = iif( !empty(bWhatShow) and bWhatShow=1, "Сообщение", " Cообщение об ошибке")
    .RETURN_VALUE = 0
ENDWITH

local laStack[1], lcStack
astackinfo(laStack)
lcStack = ""
for lnRow = alen(laStack, 1)-3  to 1 Step -1
    lcStack = lcStack + "Исп.метод:   (" + transform(laStack[lnRow,2]) + ")      " +  transform(laStack[lnRow,3]) + chr(13)+ chr(10) + ;
                        "Строка:      " + transform(laStack[lnRow,5]) + chr(13) + chr(10) + ;            
                        "Команда:     " + alltrim(transform(laStack[lnRow,6])) + chr(13)+ chr(10) + ;
                        chr(13)+ chr(10)
endfor
this.pf1.page2.aeditbox1.Value = lcStack

local lcTempFile
lcTempFile = Addbs(Sys(2023))+Sys(2015)+".tmp"
display memory to (lcTempFile) noconsole
thisform.pf1.page3.aeditbox1.Value = filetostr(lcTempFile)
erase (lcTempFile)