DEFINE CLASS posaverecord AS custom


	Height =  22 
	Width =  55 
	Name = "posaverecord"


	PROCEDURE readme
		TEXT NOSHOW  

		ВладимирМ

		Сам процесс сохранения лично я (в своей задаче) разбиваю на несколько этапов:

		Этап  0  - проверка самого факта внесения каких-либо изменений

		Этап  1  - проверка факта ввода обязательных реквизитов и проверка корректности ввода данных

		Этап  2  - формирование значений служебных полей, недоступных пользователю и заполнение прочих полей, недоступных пользователю

		Этап  3  - собственно запись в базу данных

		Этап  4  - обновление информации на формах и во временных таблицах

		Каждый этап оформляется как отдельная процедура или метод класса.

		ENDTEXT   
	ENDPROC


	*-- Проверка факта из менения записи в таблице
	PROCEDURE ischange
		*SET STEP ON 
		* IsCHANGE
		*
		* Этап  0  - проверка самого факта внесения каких-либо изменений
		* Предполагается, что таблицы находятся в каком-либо режиме буферизации, т.е.
		* речь идет об изменении буфера
		*----------------------------*
		* Возвращаемое значение llReturn
		* Возвращает .T. если были изменения записей  или .F. - если нет
		*----------------------------*
		* Параметры
		*tcAliasName - Список таблиц, через запятую, у которых следует проверить наличие изменений записи
		LPARAMETERS tcAliasName
		LOCAL llReturn
		m.llReturn=.F.

		*Если не передан параметр, то имеем ввиду, что брать текущий алиас
		IF PCOUNT()< 1 
		m.tcAliasName=SELECT( 0 )
		ENDIF

		IF TYPE('m.tcAliasName ')<>'C'
		m.tcAliasName =''
		ENDIF

		*запомним текущий алиас
		 LOCAL lcCurrentAlias
		 lcCurrentAlias=SELECT( 0 )

		* Сначала делаю разбор параметра списка таблиц
		LOCAL lnI, laAliasName[ 1 ]
		IF EMPTY(m.tcAliasName )=.F. AND ALINES(laAliasName,ChrTran(m.tcAliasName ,",",chr( 13 )),.T.)> 0 
		      FOR lnI= 1  TO ALEN(laAliasName, 1 )
		          IF USED(laAliasName[m.lnI])=.T.
		             m.llModify=.NOT.EMPTY(CHRTRAN(GETFLDSTATE(- 1 ,laAliasName[m.lnI]),"1",""))
		          ENDIF
		          *Если встретилась хоть одна модификация, то выходим из цикла
		          IF m.llModify=.T.
		            m.llReturn=.T. 
		            EXIT
		          ENDIF
		      ENDFOR
		ENDIF

		*Восстановим ситуацию
		IF TYPE('m.lcCurrentAlias')=='N'
		   SELECT (m.lcCurrentAlias)
		ENDIF 

		RETURN m.llReturn
	ENDPROC


	*-- Сохранеие положения указателя записи
	PROCEDURE saverecno
		* SaveRECNO
		*
		* Сохранеие положения указателя записи
		* в массиве-свойстве объекта
		*----------------------------*
		* Параметры
		*tcAliasName - Список таблиц, через запятую, у которых следует запомнить указатель записи
		LPARAMETERS tcAliasName
		*SET STEP ON 
		*Если не передан параметр, то имеем ввиду, что брать текущий алиас
		IF PCOUNT()< 1 
		m.tcAliasName=ALIAS()
		ENDIF

		IF TYPE('m.tcAliasName ')<>'C'
		m.tcAliasName =''
		ENDIF

		*запомним текущий алиас
		 LOCAL lcCurrentAlias
		 lcCurrentAlias=SELECT( 0 )

		THIS.AddProperty('aAliasName[1]')

		  

		* Сначала делаю разбор параметра списка таблиц
		LOCAL lnI,preaAliasName[ 1 ]
		IF EMPTY(m.tcAliasName )=.F. AND ALINES(preaAliasName,ChrTran(m.tcAliasName ,",",chr( 13 )),.T.)> 0 
		   DIMENSION  this.aAliasName[ALEN(preaAliasName, 1 ), 2 ]
		      FOR lnI= 1  TO ALEN(this.aAliasName, 1 )
		        this.aAliasName[m.lnI, 1 ]=preaAliasName[m.lnI]
		          IF USED(this.aAliasName[m.lnI])=.T.
		             *сохранение положения записи   
		             IF EOF(this.aAliasName[m.lnI, 1 ])=.F.
		                this.aAliasName[m.lnI, 2 ]=RECNO(this.aAliasName[m.lnI, 1 ])
		             ELSE
		                this.aAliasName[m.lnI, 2 ]= 0 
		             ENDIF      
		          ENDIF
		      ENDFOR
		ENDIF


		*Восстановим ситуацию
		IF TYPE('m.lcCurrentAlias')=='N'
		 SELECT (m.lcCurrentAlias)
		ENDIF 
	ENDPROC


	*-- Перемещает указатель записи на запомненное в массиве
	PROCEDURE gorecno
		* GoRECNO
		* Восстановление положения указателя записи
		* номер записи в массиве-свойстве объекта
		*----------------------------*
		* Параметры
		*tcAliasName - Список таблиц, через запятую, у которых следует восстановить указатель записи
		LPARAMETERS tcAliasName
		*SET STEP ON 
		*Если не передан параметр, то имеем ввиду, что брать текущий алиас
		IF PCOUNT()< 1 
		m.tcAliasName=ALIAS()
		ENDIF

		IF TYPE('m.tcAliasName')<>'C'
		m.tcAliasName =''
		ENDIF

		*запомним текущий алиас
		 LOCAL lcCurrentAlias
		 lcCurrentAlias=SELECT( 0 )

		IF PEMSTATUS(THIS,'aAliasName', 5 )
			* Ищем в списке таблиц
			LOCAL lnI
			  FOR lnI= 1  TO ALEN(this.aAliasName, 1 )
			      IF USED(this.aAliasName[m.lnI, 1 ])=.T. AND ;
			         ATC(this.aAliasName[m.lnI, 1 ],m.tcAliasName)> 0 
			             *Если есть запись с таким номером, то на нее и встанет, если нет , то попадем в конец файла.
			             LOCATE FOR RECNO(this.aAliasName[m.lnI, 1 ])=this.aAliasName[m.lnI, 2 ]
			      ENDIF
			  ENDFOR
		ENDIF


		*Восстановим ситуацию
		IF TYPE('m.lcCurrentAlias')=='N'
		 SELECT (m.lcCurrentAlias)
		ENDIF 

		      
	ENDPROC


	PROCEDURE messageerror
		* MessageError
		*
		* В качестве возвращаемого значения формируется сообщение об ошибке
		LOCAL lcMessageText, laError( 1 , 7 )
		EXTERNAL ARRAY gaErrors

		DO CASE
		   CASE AERROR(laError)= 0 
		   ********************************
		   * т.е. нет ошибок
		   ********************************
		   lcMessageText = ""

		   CASE laError[ 1 , 1 ]= 1526  
		   ********************************
		   * Ошибки ODBC
		   ********************************
			 DO CASE
				CASE laError[ 1 , 5 ]= 6 
				lcMessageText = 'Не удалось найти нужный сервер SQL'+chr( 13 )+;
				'Возможно, связь по сети не установлена.'
				CASE laError[ 1 , 5 ]= 229  
				lcMessageText = 'Вы вошли по паролю пользователя, который не обладает'+chr( 13 )+;
				'достаточными правами для выполнения требуемых действий'+chr( 13 )+;
				'с одним из объектов базы данных'+chr( 13 )+;
				RTRIM(SubStr(laError[ 1 , 3 ],RAT("]",laError[ 1 , 3 ])+ 1 ))+chr( 13 )+;
				'Обратитесь к администратору сервера или разработчику программы.'
				CASE laError[ 1 , 5 ]= 515  
				lcMessageText = 'Указано недопустимое значение'
				CASE laError[ 1 , 5 ]= 547  
				lcMessageText = 'Нарушение ссылочной целостности'+chr( 13 )+;
				'Нельзя удалить элемент на который ссылаются из других мест,'+chr( 13 )+;
				'либо Вы ссылаетесь на элемент которого уже не существует'
				CASE laError[ 1 , 5 ]= 1000 
				lcMessageText = 'Возможно, произошел разрыв соединения'
				CASE laError[ 1 , 5 ]= 2627  
				lcMessageText = 'Элемент с такими же ключевыми значениями уже существует' + chr( 13 )+;
				'Измените введенные значения'
				CASE laError[ 1 , 5 ]= 18456 
				lcMessageText = 'При установке соединения указано неверное имя пользователя или пароль'
				CASE laError[ 1 , 5 ]>= 50000 
				lcMessageText = 'Произошла ошибка № '+LTRIM(STR(laError[ 1 , 5 ]))+chr( 13 )+;
				RTRIM(SubStr(laError[ 1 , 3 ],RAT("]",laError[ 1 , 3 ])+ 1 ))
			 OTHERWISE
				lcMessageText = 'Произошла ошибка № '+LTRIM(STR(laError[ 1 , 5 ]))+chr( 13 )+;
				RTRIM(SubStr(laError[ 1 , 3 ],RAT("]",laError[ 1 , 3 ])+ 1 ))+chr( 13 )+;
				'Обратитесь к администратору сервера или разработчику программы.'
			 ENDCASE

		  CASE InList(laError[ 1 , 1 ], 1427 , 1429 )=.T.
		    ********************************
		    * Ошибки OLE
		     ********************************
				lcMessageText = 'Произошла ошибка в '+LTRIM(STR(laError[ 1 , 4 ]))+chr( 13 )+ALLTRIM(laError[ 1 , 3 ])
				IF IsNull(laError[ 1 , 5 ])=.F.
				  lcMessageText = lcMessageText + chr( 13 )+;
				  'подробнее о ней можно прочитать в'+chr( 13 )+ALLTRIM(laError[ 1 , 5 ])
				ENDIF

			********************************
			* Далее ошибки собственно VFP
			********************************
			CASE laError[ 1 , 1 ]= 108 
			lcMessageText = 'Произошла ошибка № 108'+chr( 13 )+;
			'Таблица используется другим пользователем.'+chr( 13 )+;
			'Никакие изменения в ней невозможны'
			CASE laError[ 1 , 1 ]= 109 
			lcMessageText = 'Произошла ошибка № 109'+chr( 13 )+;
			'Запись используется другим пользователем.'+chr( 13 )+;
			'Никакие изменения в ней невозможны'
			CASE laError[ 1 , 1 ]= 130 
			lcMessageText = 'Произошла ошибка № 130'+chr( 13 )+;
			'Одна из записей используется другим пользователем.'+chr( 13 )+;
			'Никакие изменения в ней невозможны'
			CASE laError[ 1 , 1 ]= 1539 
				* триггер вернул .F.
				LOCAL lcDopText
				lcDopText=''
				IF TYPE('gaErrors[1,2]')='C'
				lcDopText=chr( 13 )+gaErrors[ 1 , 2 ]
				ENDIF
				IF TYPE('gaErrors[1,1]')<>'N' OR gaErrors[ 1 , 1 ]=- 1 
				    lcMessageText = 'Нарушение ссылочной целостности.'
				  DO CASE
					CASE laError[ 1 , 5 ]= 1 && Insert trigger failed
					lcMessageText=m.lcMessageText+chr( 13 )+;
					'При создании документа, Вы сослались на не существующий документ'+;
					m.lcDopText
					CASE laError[ 1 , 5 ]= 2 && Update trigger failed
					lcMessageText=m.lcMessageText+chr( 13 )+;
					'При изменении документа, Вы сослались на не существующий документ'+;
					m.lcDopText
					CASE laError[ 1 , 5 ]= 3 && Delete trigger failed
					lcMessageText=m.lcMessageText+chr( 13 )+;
					'Вы удаляете документ, на который ссылаются из других документов'+;
					m.lcDopText
				  OTHERWISE&& На всякий случай.
				  ENDCASE
		        ELSE
		          lcMessageText = 'Произошла ошибка № '+LTRIM(STR(gaErrors[ 1 , 1 ]))+m.lcDopText
		        ENDIF
			CASE laError[ 1 , 1 ]= 1884 
			* Нарушение уникальности индекса типа Primary или Candidat
			lcMessageText = 'Элемент с такими же ключевыми значениями уже существует'+chr( 13 )+;
			'Измените введенные значения'+chr( 13 )+;
			'Произошла ошибка № '+LTRIM(STR(laError[ 1 , 1 ]))+chr( 13 )+ALLTRIM(laError[ 1 , 2 ])
		OTHERWISE
		    lcMessageText = 'Произошла ошибка № '+LTRIM(STR(laError[ 1 , 1 ]))+chr( 13 )+ALLTRIM(laError[ 1 , 2 ])
		ENDCASE

		RETURN (m.lcMessageText)
	ENDPROC


	PROCEDURE savebuffer
		* SAVEBUFFER
		*
		* Сброс буфера в исходные таблицы
		* Предполагается, что таблицы находятся в каком-либо режиме буферизации, т.е.
		* речь идет об изменении буфера
		*----------------------------*
		* Возвращаемое значение
		* Возвращает .T. если сброс прошел успешно или .F. - если нет
		*----------------------------*
		* Параметры
		*!* tcTableBuffer - Список таблиц, через запятую, у которых следует сбросить буфер всей таблицы
		*!* tlTransaction - Следует ли окружить сброс буфера транзакцией? Дефолт- следует .T.
		*!* tlOverWrite - Следует ли писать записи "поверх измененных" Дефолт-не следует .F.
		LPARAMETERS tcTableBuffer, tlTransaction,tlOverWrite
		*
		IF TYPE('tcTableBuffer')<>'C'
		   tcTableBuffer=''
		ENDIF
		IF TYPE('tlTransaction')<>'L' OR PCOUNT()< 2 
		   tlTransaction=.T.
		ENDIF
		IF TYPE('tlOverWrite ')<>'L' OR PCOUNT()< 2 
		   tlOverWrite=.F.
		ENDIF
		*
		LOCAL llSuccess
		llSuccess=.T.

		IF m.tlTransaction=.T.
		   BEGIN TRANSACTION
		ENDIF


		* Теперь разбираю сброс буфера таблицы
		LOCAL laTableBuffer( 1 )
		IF m.llSuccess=.T. AND EMPTY(m.tcTableBuffer)=.F. ;
		   AND ALINES(laTableBuffer,ChrTran(m.tcTableBuffer,",",chr( 13 )),.T.)> 0 
		     FOR lnI= 1  TO ALEN(laTableBuffer)
		         IF USED(laTableBuffer[m.lnI])=.T. AND CursorGetProp("Buffering",laTableBuffer[m.lnI])> 3 
		            llSuccess=TableUpdate(.T.,tlOverWrite,laTableBuffer[m.lnI])
		         ENDIF
		         IF m.llSuccess=.F.
		            EXIT
		         ENDIF
		     ENDFOR
		ENDIF

		IF m.tlTransaction=.T.
		   IF m.llSuccess=.T.
		      END TRANSACTION
		   ELSE
		      ROLLBACK
		        FOR lnI= 1  TO ALEN(laTableBuffer) 
		           TABLEREVERT(.T.,laTableBuffer[m.lnI]) &&если необходимо
		        ENDFOR   
		   ENDIF
		ENDIF

		RETURN m.llSuccess
	ENDPROC


	*-- Сохранение записей  в источниках
	PROCEDURE saverecord
		*SaveRecord-сохранение записи
		* Параметры
		*!* tcTableBuffer - Список таблиц, через запятую, у которых следует сбросить буфер всей таблицы
		*!* tlTransaction - Следует ли окружить сброс буфера транзакцией? Дефолт- следует .T.
		*!* tlOverWrite - Следует ли писать записи "поверх измененных" Дефолт-не следует .F.
		LPARAMETERS tcTableBuffer, tlTransaction,tlOverWrite
		*SET STEP ON 

		IF TYPE('tcTableBuffer')<>'C'
		tcTableBuffer=''
		ENDIF
		IF TYPE('tlTransaction')<>'L' OR PCOUNT()< 3 
		tlTransaction=.T.
		ENDIF
		IF TYPE('tlOverWrite ')<>'L' OR PCOUNT()< 3 
		tlOverWrite=.F.
		ENDIF


		LOCAL lcMessageText, laError( 1 ), llOverWrite
		FOR lnI= 1  TO  2 
		tlOverWrite = (m.lnI= 2 )
		* По умолчанию, цикл выполняем только  1  раз
		lnI= 2 
		* Выполняем попытку сохранения
		IF this.SaveBuffer(tcTableBuffer, tlTransaction,tlOverWrite) = .F.
		    * Сначала определяю номер ошибки
		    =AERROR(laError)
		    * Теперь формирую сообщение об ошибке
		    lcMessageText = this.MessageError()
		    * Если ошибка - это модификация другим пользователем,
		    * то дополнительный запрос
		    IF laError[ 1 , 1 ]= 1585 
		       lcMessageText ='Кто-то уже обновил эти данные.'++chr( 13 )+;
		                       m.lcMessageText +chr( 13 )+;
		                       +chr( 13 )+;
		                      'Писать поверх этих изменений?'
		       IF MessageBox(m.lcMessageText, 4 + 32 + 256 ,'Конфликт обновления')= 6 
		         * Пошли на второй заход цикла
		          m.lnI= 1 
		       ENDIF
		    ELSE
		      MessageBox(m.lcMessageText, 16 ,"Ошибка обновления")
		    ENDIF
		    
		ENDIF
		ENDFOR
	ENDPROC


	PROCEDURE delrecord
		*DelRecord
		*удаление записи в буферизированном источнике
		*Перед удалением сохранить указатель записи,
		*после на представлении вделать реквери, затем восстановить положение записи
		*----------------------------*
		* Параметры
		* tcAliasName - Список таблиц, через запятую, у которых следует удалить текущую запись
		* tlquestionDel - Следует ли спросить юзера об удалении записи
		* tlTransaction - Следует ли окружить сброс буфера транзакцией?
		* tlOverWrite - Следует ли писать записи "поверх измененных" Дефолт-не следует .F.
		LPARAMETERS tcAliasName , tlquestionDel ,tlTransaction ,tlOverWrite

		IF TYPE('tcAliasName')<>'C'
		  tcAliasName=''
		ENDIF

		IF TYPE('tlquestionDel')<>'L' OR PCOUNT()< 2 
		  tlquestionDel=.F.
		ENDIF


		IF TYPE('tlTransaction')<>'L' OR PCOUNT()< 3 
		  tlTransaction=.T.
		ENDIF

		IF TYPE('tlOverWrite ')<>'L' OR PCOUNT()< 3 
		  tlOverWrite=.F.
		ENDIF

		IF tlquestionDel=.T.
		   IF  MESSAGEBOX("Вы действительно хотите удалить запись/записи ?"+CHR( 13 )+;
		                  "                                        ", 1 + 16 + 256 ,"Удаление выбранной записи")= 2 
		       RETURN .F. 
		   ENDIF 
		ENDIF  


		*Удаление записи, проверяем если представление, по просто в нем таблереверт
		BEGIN TRANSACTION  

		LOCAL laAliasName ( 1 ),llReturnTransaction
		llReturnTransaction=.f. 
		IF EMPTY(m.tcAliasName )=.F. ;
		   AND ALINES(laAliasName ,ChrTran(m.tcAliasName ,",",chr( 13 )),.T.)> 0 
		     FOR lnI= 1  TO ALEN(laAliasName)
		         IF USED(laAliasName[m.lnI])=.T. AND INLIST(CursorGetProp("SourceType",laAliasName[m.lnI]), 1 , 2 );
		            AND RECNO(laAliasName[m.lnI])< 0   
		             * Эта запись добавлена в представление и еще не сохранялась  
		             * Поэтому достаточно отказаться от нее в представлении  
		                TABLEREVERT(.f.,laAliasName[m.lnI])  
		         ELSE 
		          *
		            IF USED(laAliasName[m.lnI])=.T. AND !BOF(laAliasName[m.lnI]).OR. !EOF(laAliasName[m.lnI])
		               DELETE IN (laAliasName[m.lnI])
		               llReturnTransaction=.T. 
		            ELSE    
		               llReturnTransaction=.F. 
		               EXIT 
		            ENDIF    
		         ENDIF
		    ENDFOR
		ENDIF

		IF m.llReturnTransaction=.T.
		   END TRANSACTION
		ELSE
		   ROLLBACK
		   * Теперь обработка ошибки, но ПОСЛЕ ЗАКРЫТИЯ ТРАНЗАКЦИИ  
		   AERROR(laError0)
		   MESSAGEBOX("При попытке удаления записей произшла ошибка № "+TRANSFORM(laError0[ 1 , 1 ])+CHR( 13 )+;
		              "Обратитесь к администратору или разработчику"+CHR( 13 )+;
		              "Сохранение невозможно", 0 + 16 + 0 ,'Ошибка удаления!!!') 
		ENDIF


		LOCAL lcMessageText, laError( 1 ), llOverWrite
		FOR lnI= 1  TO  2 
		tlOverWrite = (m.lnI= 2 )
		* По умолчанию, цикл выполняем только  1  раз
		lnI= 2 
		* Выполняем попытку сохранения
		IF this.SaveBuffer(tcAliasName,tlTransaction,tlOverWrite) = .F.
		    * Сначала определяю номер ошибки
		    =AERROR(laError)
		    * Теперь формирую сообщение об ошибке
		    lcMessageText = this.MessageError()
		    * Если ошибка - это модификация другим пользователем,
		    * то дополнительный запрос
		    IF laError[ 1 , 1 ]= 1585 
		       lcMessageText ='Кто-то уже обновил эти данные.'++chr( 13 )+;
		                       m.lcMessageText +chr( 13 )+;
		                       +chr( 13 )+;
		                      'Писать поверх этих изменений?'
		       IF MessageBox(m.lcMessageText, 4 + 32 + 256 ,'Конфликт обновления')= 6 
		         * Пошли на второй заход цикла
		          m.lnI= 1 
		       ENDIF
		    ELSE
		      MessageBox(m.lcMessageText, 16 ,"Ошибка обновления")
		    ENDIF
		    
		ENDIF
		ENDFOR
	ENDPROC


	*-- Добавление записи в группу таблиц
	PROCEDURE newrecord
		* GoRECNO
		* LOCATE for RECNO() = lnRecno Если есть запись с таким номером, то на нее и встанет, если нет , то попадем в конец файла.
		* Восстановление положения указателя записи
		* номера записи в массиве-свойстве объекта
		*----------------------------*
		* Параметры
		*tcAliasName - Список таблиц, через запятую, в которые следует добавить новые записи
		LPARAMETERS tcAliasName
		*SET STEP ON 
		*Если не передан параметр, то имеем ввиду, что брать текущий алиас
		IF PCOUNT()< 1 
		m.tcAliasName=ALIAS()
		ENDIF

		IF TYPE('m.tcAliasName')<>'C'
		m.tcAliasName =''
		ENDIF

		*запомним текущий алиас
		 LOCAL lcCurrentAlias
		 lcCurrentAlias=SELECT( 0 )

		IF EMPTY(m.tcAliasName )=.F. ;
		   AND ALINES(laAliasName ,ChrTran(m.tcAliasName ,",",chr( 13 )),.T.)> 0 
		     FOR lnI= 1  TO ALEN(laAliasName)
		         IF USED(laAliasName[m.lnI])=.T.
		            APPEND BLANK IN (laAliasName[m.lnI])  
		         ENDIF 
		     ENDFOR 
		ENDIF      


		*Восстановим ситуацию
		IF TYPE('m.lcCurrentAlias')=='N'
		 SELECT (m.lcCurrentAlias)
		ENDIF 
	ENDPROC


ENDDEFINE
*
*-- EndDefine: posaverecord
**************************************************

LOCAL lcMessageText, laError( 1 ), llOverWrite
FOR lnI= 1  TO  2 
llOverWrite = (m.lnI= 2 )
* По умолчанию, цикл выполняем только  1  раз
lnI= 2 
* Выполняем попытку сохранения
IF Save_Buffer("Table1,Table2","Table3,Table4",.T.,m.llOverWrite) = .F.
* Сначала определяю номер ошибки
=AERROR(laError)
* Теперь формирую сообщение об ошибке
lcMessageText = MessageError()
* Если ошибка - это модификация другим пользователем,
* то дополнительный запрос
IF laError[ 1 , 1 ]= 1585 
lcMessageText = m.lcMessageText +chr( 13 )+;
'Писать поверх?'
IF MessageBox(m.lcMessageText, 4 + 32 + 256 )= 6 
* Пошли на второй заход цикла
m.lnI= 1 
ENDIF
ELSE
MessageBox(m.lcMessage)
ENDIF
ENDIF
ENDFOR