Private Function fnDT_ASSETS_CT_ASSETS_02( _
ByRef bFail As Boolean, _
ByVal bShowErrors As Boolean) As Boolean
'<EhHeader>
On Error GoTo fnDT_ASSETS_CT_ASSETS_02_Err
'</EhHeader>
Const ERR_LOC = "ПРОЦЕДУРА: fnDT_ASSETS_CT_ASSETS_02" & vbCrLf
Dim bRetVal As Boolean 'Возвращаемое значение (успех)
Dim bTransaction As Boolean 'Начата ли транзакция?
'Записи таблицы t_TEMP_ZATR
Dim aTempZatr() As type_TEMP_ZATR '(редактируемые)
Dim y&, M As Long 'Для цикла по массиву.
'Записи текущего документа:
Dim aRecAssDt() As type_REGASSETS 'в t_REGASSETS (новые)
Dim aRecAssCt() As type_REGASSETS 'в t_REGASSETS (новые)
Dim i&, N As Long 'Для цикла по массивам.
Dim nZatrSum As Currency 'Сумма на счёте по статье затрат.
Dim nZatrYear As Integer 'Год начисления затрат
Dim nZatrMonth As Integer 'Месяц начисления затрат
'Записи на счетах-источниках:
Dim aRecBound() As type_REGASSETS 'в t_REGASSETS (редактируемые)
Dim bFilter As Boolean 'Временный фильтр поиска
Dim bNeedNewDate As Boolean 'Нужно обновить дату поиска?
Dim nRestSum As Currency 'Остаток суммы операции для списания.
Dim nRestQnt As Currency 'Остаток кол-ва операции для списания.
Dim nOnBalnceSum As Currency 'Сумма на балансе по искомому счёту.
Dim nOnBalnceRow As Currency 'Сумма на балансе по текущей строке.
' Dim nOnBalQNTsum As Currency 'Кол-во на балансе по искомому счёту.
' Dim nOnBalQNTrow As Currency 'Кол-во на балансе по текущей строке.
Dim nCurrSum As Currency 'Текущая сумма активов для переноса
Dim nCurrQnt As Currency 'Текущее кол-во активов для переноса
Dim nTempSum As Currency 'Вспомогательные переменные.
Dim nFullSum As Currency
Dim nTempQnt As Currency
Dim nEndOfMonth As Integer 'Дата конца текущего месяца
100 If nNomenId < 2& Then 'Проверка наличия номенк-ры.
102 PrintLog ErrHeader & ERR_LOC & _
"Попытка переместить актив без номенклатуры." & vbCrLf
104 GoTo HELL
End If
106 With t_SPR_DATES 'Определяем дату окончания
108 .Index = "PrimaryKey" 'месяца или, при проблемах
110 .Seek "=", nDateId 'с разнесением, дату окон-
112 If bShowErrors Then 'чания квартала.
114 nEndOfMonth = DateSerial(!DATE_YEAR, !DATE_MONTH \ 3 + 4, 1) - 1 - DATE_OFFSET
Else
116 nEndOfMonth = DateSerial(!DATE_YEAR, !DATE_MONTH + 1, 1) - 1 - DATE_OFFSET
End If
End With
118 GoSub FIND_TEMP_ZATR
120 bRetVal = True
122 GoTo HELL
'ПОДПРОГРАММА ПОЛУЧЕНИЯ СТРУКТУРЫ АНАЛИТИКИ ТЕКУЩЕЙ СТАТЬИ ЗАТРАТ
FIND_TEMP_ZATR:
124 M = 0& 'Кол-во записей аналитики.
126 nZatrSum = 0@ 'Сумма на счёте по ст.затрат
128 ReDim aTempZatr(1& To ARR_BLOCK) 'Массив аналитики статьи затрат
130 nZatrYear = Year(nDateId + DATE_OFFSET)
132 nZatrMonth = Month(nDateId + DATE_OFFSET)
134 With t_TEMP_ZATR
'Проверим статью затрат. ссылки на статью затрат в 1С могут
'отсутствовать, несмотря на то, что они должны здесь
'быть (ID = 2). В этом случае индекс не учитывает ZATR_ID.
136 If nZatrId = 2 Then
'Кроме того, если на предыдущих итерациях не удалось
'найти затраты на счёте-источнике (bShowErrors), то
'исключаем из индекса период начисления (ищем просто
'по счёту и, при наличии, по статье затрат).
138 If bShowErrors Then
140 .Index = "NOTCLEAN_ACC"
142 .Seek "=", True, nAccIdCt
Else
144 .Index = "NOTCLEAN_ACC_YEAR_MONTH"
146 .Seek "=", True, nAccIdCt, nZatrYear, nZatrMonth
End If
Else
148 If bShowErrors Then
150 .Index = "NOTCLEAN_ACC_ZATR"
152 .Seek "=", True, nAccIdCt, nZatrId
Else
154 .Index = "NOTCLEAN_ACC_ZATR_YEAR_MONTH"
156 .Seek "=", True, nAccIdCt, nZatrId, nZatrYear, nZatrMonth
End If
End If
158 If .NoMatch Then
160 bFail = True
162 If bShowErrors Then PrintLog ErrHeader & ERR_LOC & _
"Затраты на счёте-источнике (КТ) не найдены." & vbCrLf
164 GoTo HELL
End If
166 bFilter = (nZatrId > 2) Imp (!ZATR_ID = nZatrId)
168 bFilter = bFilter And (!ACC_ID = nAccIdCt)
170 If bShowErrors = False Then
172 bFilter = bFilter And (!DATE_MONTH = nZatrMonth)
174 bFilter = bFilter And (!DATE_YEAR = nZatrYear)
End If
176 bFilter = bFilter And (!IS_NOT_CLEAN)
178 Do While bFilter
180 M = M + 1
182 If M Mod ARR_BLOCK = 0& Then 'Приращаем массив.
184 ReDim Preserve aTempZatr(1& To M + ARR_BLOCK)
End If
'Получаем текущую запись
186 If fnReadTempZatr(t_TEMP_ZATR, aTempZatr(M)) = False Then
188 PrintLog ErrHeader & ERR_LOC & _
"Процедура fnReadTempZatr(aTempZatr) вернула ошибку." & vbCrLf
190 GoTo HELL
End If
'Считаем сумму по ст.затрат.
192 nZatrSum = nZatrSum + !ASS_SUM_BALANCE
194 .MoveNext
196 If .EOF Then Exit Do
198 bFilter = (nZatrId > 2) Imp (!ZATR_ID = nZatrId)
200 bFilter = bFilter And (!ACC_ID = nAccIdCt)
202 If bShowErrors = False Then
204 bFilter = bFilter And (!DATE_MONTH = nZatrMonth)
206 bFilter = bFilter And (!DATE_YEAR = nZatrYear)
End If
208 bFilter = bFilter And (!IS_NOT_CLEAN)
Loop
End With
210 If M = 0& Then
212 bFail = True
214 If bShowErrors Then PrintLog ErrHeader & ERR_LOC & _
"Затраты на счёте-источнике (КТ) не найдены." & vbCrLf
216 GoTo HELL
218 ElseIf ((nZatrSum > 0@) And (nOperSum > 0@) _
And (nZatrSum < (nOperSum - 0.004@))) _
Or ((nZatrSum < 0@) And (nOperSum < 0@) _
And (nZatrSum > (nOperSum + 0.004@))) Then
220 bFail = True
222 If bShowErrors Then PrintLog ErrHeader & ERR_LOC & _
"Затраты на счёте-источнике (КТ) " & _
"в необходимой сумме не найдены." & vbCrLf
224 GoTo HELL
End If
226 nFullSum = nOperSum
228 nRestSum = nOperSum
230 For y = 1& To M 'Формируем суммы по структуре
'Если поиск был осуществлён без учёта статьи затрат
'(nZatrId = 2), то в массиве aTempZatr будет несколько
'статей затрат (они упорядочены). После обработки записей,
'относящихся к первой статье затрат, вся сумма может быть
'распределена, и необходимо выйти из цикла.
232 If nRestSum = 0@ Then Exit For 'аналитики статьи затрат.
234 With aTempZatr(y)
236 If y > 1& Then
'Если поиск был осуществлён без учёта статьи затрат
'(nZatrId = 2), то для каждой новой статьи затрат
'нужно правильно указать сумму для распределения.
238 If aTempZatr(y).ZATR_ID <> aTempZatr(y - 1).ZATR_ID Then
240 nFullSum = nRestSum
End If
End If
242 nTempSum = Round(nFullSum * .DELTA, 4)
244 nTempQnt = Round(.ASS_QNT_BALANCE * nTempSum / .ASS_SUM_BALANCE, 4)
246 If (.ASS_SUM_BALANCE > 0@) Then
'Изначально положительные остатки не должны стать < 0
'(есть несколько итераций, и отрицательные документы
' могут в последствии увеличить остаток, чтобы
' можно было обработать пропущенный документ)
248 If (.ASS_SUM_BALANCE - nTempSum >= 0@) Then
250 .ASS_SUM_BALANCE = .ASS_SUM_BALANCE - nTempSum
252 .ASS_QNT_BALANCE = .ASS_QNT_BALANCE - nTempQnt
254 .OPER_SUM = nTempSum
256 .OPER_QNT = nTempQnt
258 nRestSum = nRestSum - .OPER_SUM
'Дальше обрабатываем разные погрешности округления
260 If (.ASS_SUM_BALANCE <= 0.004@) _
And (nRestSum >= 0.004@) Then
262 nRestSum = nRestSum - .ASS_SUM_BALANCE
264 .OPER_SUM = .OPER_SUM + .ASS_SUM_BALANCE
266 .OPER_QNT = .OPER_QNT + .ASS_QNT_BALANCE
268 .ASS_SUM_BALANCE = 0@
270 .ASS_QNT_BALANCE = 0@
End If
272 If (nRestSum < 0.004@) And (nRestSum > -0.004@) _
And (nRestSum <> 0@) _
And (.ASS_SUM_BALANCE >= nRestSum) Then
274 .ASS_SUM_BALANCE = .ASS_SUM_BALANCE - nRestSum
276 .OPER_SUM = .OPER_SUM + nRestSum
278 nRestSum = 0@
End If
'Если и операция и остаток положительные, но просто
'не хватает суммы остатка, то списываем столько,
'сколько есть.
280 ElseIf nTempSum > 0@ Then
282 .OPER_SUM = .ASS_SUM_BALANCE
284 .OPER_QNT = .ASS_QNT_BALANCE
286 .ASS_SUM_BALANCE = 0@
288 .ASS_QNT_BALANCE = 0@
290 nRestSum = nRestSum - .OPER_SUM
End If
Else
'Те же операции для отрицательных остатков.
292 If (.ASS_SUM_BALANCE - nTempSum <= 0@) Then
294 .ASS_SUM_BALANCE = .ASS_SUM_BALANCE - nTempSum
296 .ASS_QNT_BALANCE = .ASS_QNT_BALANCE - nTempQnt
298 .OPER_SUM = nTempSum
300 .OPER_QNT = nTempQnt
302 nRestSum = nRestSum - .OPER_SUM
'Дальше обрабатываем разные погрешности округления
304 If (.ASS_SUM_BALANCE >= -0.004@) _
And (nRestSum <= -0.004@) Then
306 nRestSum = nRestSum - .ASS_SUM_BALANCE
308 .OPER_SUM = .OPER_SUM + .ASS_SUM_BALANCE
310 .OPER_QNT = .OPER_QNT + .ASS_QNT_BALANCE
312 .ASS_SUM_BALANCE = 0@
314 .ASS_QNT_BALANCE = 0@
End If
316 If (nRestSum > -0.004@) And (nRestSum < 0.004@) _
And (nRestSum <> 0@) _
And (.ASS_SUM_BALANCE <= nRestSum) Then
318 .ASS_SUM_BALANCE = .ASS_SUM_BALANCE - nRestSum
320 .OPER_SUM = .OPER_SUM + nRestSum
322 nRestSum = 0@
End If
324 ElseIf nTempSum < 0@ Then
326 .OPER_SUM = .ASS_SUM_BALANCE
328 .OPER_QNT = .ASS_QNT_BALANCE
330 .ASS_SUM_BALANCE = 0@
332 .ASS_QNT_BALANCE = 0@
334 nRestSum = nRestSum - .OPER_SUM
End If
End If
End With
Next
'Проверяем, что вся сумма операции распределилась корректно.
336 If nRestSum <> 0@ Then
338 PrintLog ErrHeader & ERR_LOC & _
"Ошибка программирования. Не смог распределить " & _
"документ по аналитике статьи затрат." & vbCrLf
340 GoTo HELL
End If
'Имея структуру аналитики, мы теперь для каждой записи в
'aTempZatr(y) будем искать подходящие первичные документы
'и списывать с них суммы по принципу FIFO.
342 For y = 1& To M
344 With aTempZatr(y)
346 If CBool(.OPER_SUM) Then
348 GoSub FIND_ASSETS_PRODUCTION
End If
End With
Next
350 oWorkspase.BeginTrans 'НАЧАЛО ТРАНЗАКЦИИ
352 bTransaction = True
354 For y = 1& To M
356 If Edit_TEMPZATR(aTempZatr(y)) = False Then
358 PrintLog ErrHeader & ERR_LOC & _
"Процедура Edit_TEMPZATR(aTempZatr) вернула ошибку. y=" & y & vbCrLf
360 oWorkspase.Rollback
362 bTransaction = False
364 GoTo HELL
End If
Next
366 oWorkspase.CommitTrans 'КОНЕЦ ТРАНЗАКЦИИ
368 bTransaction = False
370 Return
'ПОДПРОГРАММА ПОИСКА И РАСПРЕДЕЛЕНИЯ ПО СТАТЬЯМ АКТИВОВ
'СО СЧЁТА-ИСТОЧНИКА ПО СТАТЬЕ ЗАТРАТ И ПОДРАЗДЕЛЕНИЮ.
FIND_ASSETS_PRODUCTION:
372 N = 0& 'Кол-во связанных записей.
374 ReDim aRecBound(1& To ARR_BLOCK) 'Массив связанных активов.
376 nOnBalnceSum = 0@ 'Сумма на балансе.
378 With t_REGASSETS 'Перебираем активы по
380 .Index = "NOTCLEAN_ACC_NOMEN_DATE_DOC" 'счёту-источнику (Кт).
382 bNeedNewDate = True
384 .SeekRecord ">=", True, nAccIdCt, aTempZatr(y).NOMEN_ID, _
CleanDay(nAccIdCt, aTempZatr(y).NOMEN_ID), 0
386 If .NoMatch Then
388 bFail = True
390 If bShowErrors Then PrintLog ErrHeader & ERR_LOC & _
"Активы на счёте-источнике (КТ) не найдены." & vbCrLf
392 GoTo HELL
End If
394 Do While (!ASS_DATE <= nEndOfMonth) And (!ACC_ID = nAccIdCt) _
And (!IS_NOT_CLEAN) And (!NOMEN_ID = aTempZatr(y).NOMEN_ID)
396 nOnBalnceRow = !ASS_SUM_BALANCE
398 bFilter = (!ZATR_ID = aTempZatr(y).ZATR_ID)
400 bFilter = bFilter And (!PODRAZ_ID = aTempZatr(y).PODRAZ_ID)
402 If bNeedNewDate Then 'Обновляем дату поиска
404 CleanDay(nAccIdCt, aTempZatr(y).NOMEN_ID) = !ASS_DATE - 1
406 bNeedNewDate = False '(однократно).
End If
408 If bFilter Then
410 N = N + 1
412 If N Mod ARR_BLOCK = 0& Then 'Приращаем массив.
414 ReDim Preserve aRecBound(1& To N + ARR_BLOCK)
End If
'Получаем текущую запись
416 If fnReadRegassets(t_REGASSETS, aRecBound(N)) = False Then
418 PrintLog ErrHeader & ERR_LOC & _
"Процедура fnReadRegassets(aRecBound) вернула ошибку." & vbCrLf
420 GoTo HELL
End If
'Отбираем необходимое кол-во
'записей по сумме и кол-ву.
422 nOnBalnceSum = nOnBalnceSum + nOnBalnceRow
424 With aTempZatr(y)
426 If (Abs(nOnBalnceSum) >= Abs(.OPER_SUM)) _
And ((nOnBalnceSum > 0@) = (.OPER_SUM > 0@)) Then
Exit Do
End If
End With
End If
428 .MoveNext
430 If .EOF Then Exit Do
Loop
End With
432 If N = 0& Then
434 bFail = True
436 If bShowErrors Then PrintLog ErrHeader & ERR_LOC & _
"Активы на счёте-источнике (КТ) не найдены." & vbCrLf
438 GoTo HELL
End If
440 nRestSum = aTempZatr(y).OPER_SUM
442 nRestQnt = aTempZatr(y).OPER_QNT
444 ReDim Preserve aRecBound(1& To N)
446 ReDim aRecAssDt(1& To N)
448 ReDim aRecAssCt(1& To N)
450 For i = 1& To N
452 With aRecBound(i) 'Распред.сумму по строкам
454 If i = N Then
456 nCurrSum = nRestSum
458 nCurrQnt = nRestQnt
Else
460 nCurrSum = .ASS_SUM_BALANCE
462 nCurrQnt = .ASS_QNT_BALANCE
End If
464 .ASS_SUM_BALANCE = .ASS_SUM_BALANCE - nCurrSum
466 .ASS_QNT_BALANCE = .ASS_QNT_BALANCE - nCurrQnt
468 nRestSum = nRestSum - nCurrSum
470 nRestQnt = nRestQnt - nCurrQnt
End With
472 With aRecAssDt(i) 'Проводка по дебету
474 .ASS_DATE = nDateId
476 .DOC_ID = nDocId
478 .OPER_ID = nOperId
480 .VZ_ID = aRecBound(i).VZ_ID
482 .NOMEN_ID = nNomenId
484 .PODRAZ_ID = aRecBound(i).PODRAZ_ID
486 .ZATR_ID = nZatrId
488 .ACC_ID = nAccIdDt
490 .ASS_SUM = nCurrSum
492 .ASS_NDS = 0@
494 .ASS_SUM_BALANCE = nCurrSum
496 .ASS_QNT_BALANCE = nCurrQnt
498 .ASS_QNT = nCurrQnt
500 .DESCR_ID = nDescrId
502 .REL_DOC_ID = nRelDocId
End With
504 With aRecAssCt(i) 'Проводка по кредиту
506 .ASS_DATE = nDateId
508 .DOC_ID = nDocId
510 .OPER_ID = nOperId
512 .VZ_ID = aRecBound(i).VZ_ID
514 .NOMEN_ID = nNomenId
516 .PODRAZ_ID = aRecBound(i).PODRAZ_ID
518 .ZATR_ID = nZatrId
520 .ACC_ID = nAccIdCt
522 .ASS_SUM = -nCurrSum
524 .ASS_NDS = 0@
526 .ASS_SUM_BALANCE = 0@
528 .ASS_QNT_BALANCE = 0@
530 .ASS_QNT = -nCurrQnt
532 .DESCR_ID = nDescrId
534 .REL_DOC_ID = nRelDocId
End With
Next
536 oWorkspase.BeginTrans 'НАЧАЛО ТРАНЗАКЦИИ
538 bTransaction = True
540 For i = 1& To N
542 If Not ((aRecAssDt(i).ASS_SUM = 0@) And (aRecAssDt(i).ASS_QNT_BALANCE = 0@)) Then
544 If Edit_REGASSETS(aRecBound(i)) = False Then
546 PrintLog ErrHeader & ERR_LOC & _
"Процедура Edit_REGASSETS(aRecBound) вернула ошибку. i=" & i & vbCrLf
548 oWorkspase.Rollback
550 bTransaction = False
552 GoTo HELL
End If
554 If AddNew_REGASSETS(aRecAssDt(i)) = False Then
556 PrintLog ErrHeader & ERR_LOC & _
"Процедура AddNew_REGASSETS(aRecAssDt) вернула ошибку. i=" & i & vbCrLf
558 oWorkspase.Rollback
560 bTransaction = False
562 GoTo HELL
End If
564 If AddNew_REGASSETS(aRecAssCt(i)) = False Then
566 PrintLog ErrHeader & ERR_LOC & _
"Процедура AddNew_REGASSETS(aRecAssCt) вернула ошибку. i=" & i & vbCrLf
568 oWorkspase.Rollback
570 bTransaction = False
572 GoTo HELL
End If
End If
Next
574 oWorkspase.CommitTrans 'КОНЕЦ ТРАНЗАКЦИИ
576 bTransaction = False
578 Return
HELL:
On Error Resume Next
580 If bTransaction Then oWorkspase.Rollback
582 fnDT_ASSETS_CT_ASSETS_02 = bRetVal
'<EhFooter>
Exit Function
fnDT_ASSETS_CT_ASSETS_02_Err:
PrintLog Err.Description & " BuhDoc.MProcessHeap.fnDT_ASSETS_CT_ASSETS_02. Строка:" & Erl
GoTo HELL
'</EhFooter>
End Function