Attribute VB_Name = "RROExcelClientInit"
Option Explicit
Private DOCUMENTS_REESTR_CODE As Long 	 	' код объекта расходное обязательство
Private DICTIONARY_NORM_DOC As Long 	 	' НПА
Private DICTIONARY_PREC_DOC As Long 	 	' выписка из НПА
Private DICTIONARY_SODERG_RO As Long 	 	' полномочие
Private DICTIONARY_UTOCH_FIELD As Long 	 	' уточняющее поле
Private DICTIONARY_SECTOR_BUDGET As Long 	' расходы бюджета
Private DICTIONARY_MEMO_RO As Long 		 	' примечание РО
Private COLUMN_REESTR_RO_EXPLAIN As Long 	' обоснование
Private COLUMN_REESTR_RO_RATE AS Long 	 	' показатель
Private DICTIONARY_GROUP_RO As Long 		' категории
Private PLAN_SUM_REESTR_RO As Long 			' плановая сумма
Private ACTUAL_SUM_REESTR_RO As Long 		' фактическая сумма

Private DICTIONARY_BK_IST As Long 			' соответствие комбинаций БК
Private REFERENCE_DEPARTMENT As Long 		' ссылка на ведомство
Private DICTIONARY_DEPARTMENT As Long 		' ссылка на ведомство
Private DICTIONARY_DIVISION As Long 	 	' справочник подразделов
Private REFERENCE_DIVISION As Long 			' ссылка на подраздел
Private DICTIONARY_TARGET_ITEM  As Long 	' справочник целевых статей
Private REFERENCE_TARGET_ITEM  As Long 		' ссылка на целевую статью
Private DICTIONARY_EXPEND As Long 			' справочник расходов
Private REFERENCE_EXPEND As Long 			' ссылка на вид расхода
Private DICTIONARY_ITEM As Long 			' справочник КОСГУ
Private REFERENCE_ITEM As Long 				' ссылка на КОСГУ
Private DICTIONARY_ADD_BK As Long 			' справочник доп.классификаций
Private REFERENCE_ADD_BK As Long 			' ссылка на доп.классификацию
Private DICTIONARY_KBK_LOCAL As Long		' справочник рег.классификаций
Private REFERENCE_KBK_LOCAL As Long 		' ссылка на рег.классификацию

Public Type KBK
	CDEP As String
	CDIV As String
	CTGT As String
	CEXP As String
	CITEM As String
	CADD_BK As String
	CLCL As String
	
	S_FACT0 As Double
	S_PLAN0 As Double
	S_PLAN1 As Double
	S_PLAN2 As Double
	S_PLAN3 As Double
	S_PLAN4 As Double
End Type

Public Type ShortItemId
   cb As Long
   abID As Byte
End Type

Public Type ITEMIDLIST
   mkid As ShortItemId
End Type

Public oConnection
Public Declare Function GetShortPathName Lib "kernel32" Alias "GetShortPathNameA" (ByVal lpszLongPath As String, ByVal lpszShortPath As String, ByVal lBuffer As Long) As Long
Private Declare Function SHGetSpecialFolderLocation Lib "shell32.dll" (ByVal hwndOwner As Long, ByVal nFolder As Long, pidl As ITEMIDLIST) As Long
Public Declare Function SHGetPathFromIDList Lib "shell32.dll" (ByVal pidl As Long, ByVal pszPath As String) As Long

Public Const LOCALE_USER_DEFAULT = &H400
Public Const LOCALE_DECIMAL = &HE
Public Declare Function GetLocaleInfo Lib "kernel32" Alias "GetLocaleInfoA" (ByVal Locale As Long, ByVal LCType As Long, ByVal lpLCData As String, ByVal cchData As Long) As Long

Sub HideUselessSheet(nParam As String) 
	Dim oSheet As Worksheet
	For Each oSheet In ActiveWorkbook.Sheets
		If ((oSheet.Name LIKE "РРО*"  Or oSheet.Name LIKE "Черновик РРО*" Or oSheet.Name LIKE "76Н*") And oSheet.Range("A10").Value = "Добавить") Then
			oSheet.Visible = False
		End If
	Next
End Sub

Public Function GetDataList(ByVal sourceRange As Range, ByVal sortedRange As Range) As Variant()
    sourceRange.Copy sortedRange
    sortedRange.Select
    With Selection
        .Sort Key1:=sortedRange.Cells(1, 1), Order1:=xlAscending, Header:=xlGuess, _
        OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
        DataOption1:=xlSortNormal
    End With
    Dim endRange As Range
    Dim tempRange As Range
    'Set endRange = sortedRange.SpecialCells(xlCellTypeBlanks)
    'endRange.Select
    'Set tempRange = sortedRange.Cells(1, 2)
    'Set sortedRange = Range(endRange.Cells(1, 1), tempRange)
    sortedRange.Select
    Dim arr() As Variant
    Dim nCounter As Long
    Dim arrayIndex As Long
    Dim lastValue As String
    lastValue = 0
    arrayIndex = 0
    ReDim arr(sortedRange.Rows.Count, 1)
    For nCounter = 1 To sortedRange.Rows.Count
        If Not IsEmpty(sortedRange.Cells(nCounter, 2).Value) And sortedRange.Cells(nCounter, 1).Value <> lastValue Then
            lastValue = sortedRange.Cells(nCounter, 1).Value
            arr(arrayIndex, 0) = sortedRange.Cells(nCounter, 1).Value
            arr(arrayIndex, 1) = sortedRange.Cells(nCounter, 2).Value
            arrayIndex = arrayIndex + 1
        End If
    Next nCounter
    GetDataList = arr
End Function

Function StrSplit(strSource As String) As Variant()
    Dim vStrings() As String
    Dim strArray() As Variant
    Dim strControlArray() As Variant
    Dim vParsedStrings() As Variant
    
	If (strSource = "" Or IsEmpty(strSource)) Then
		StrSplit = Array()
		Exit Function
	End If
	
    strArray = Array("абз.", "п.", "подп.", "ч.", "ст.", "гл.", "разд.", "подс.")
    strControlArray = Array("Абзац", "Пункт", "Подпункт", "Часть", "Статья", "Глава", "Раздел", "Подстатья")
    
    vStrings = Split(strSource, vbLf, -1, vbTextCompare)
    ReDim vParsedStrings(UBound(vStrings), 1) ' двумерный массив
    
    Dim i As Integer
    Dim j As Integer
    
    For i = LBound(vStrings) To UBound(vStrings)
       vParsedStrings(i, 0) = Trim(vStrings(i))
    Next i
    
    For i = LBound(vParsedStrings) To UBound(vParsedStrings)
        For j = LBound(strArray) To UBound(strArray)
            If (InStr(1, vParsedStrings(i, 0), strArray(j), vbTextCompare) = 1) Then
                vParsedStrings(i, 1) = Mid(vParsedStrings(i, 0), Len(strArray(j)) + 1, Len(vParsedStrings(i, 0)))
                vParsedStrings(i, 0) = strControlArray(j)
                Exit For
            End If
        Next j
    Next i
    StrSplit = vParsedStrings
End Function

Sub HideColumns(ByVal nMode As Integer)
	Dim oSheet As Worksheet
	For Each oSheet In ActiveWorkbook.Sheets
		If (oSheet.Name LIKE "РРО*" Or oSheet.Name LIKE "Черновик РРО*" Or osheet.Name LIKE "76Н*") Then
			With Worksheets(oSheet.Name)
				.Columns(3).EntireColumn.Hidden  = True ' Столбец C
				.Columns(6).EntireColumn.Hidden  = True ' Столбец F
				.Columns(7).EntireColumn.Hidden  = True ' Столбец G
				.Columns(8).EntireColumn.Hidden  = True ' Столбец H
				.Columns(30).EntireColumn.Hidden = True ' Столбец AD
				.Columns(38).EntireColumn.Hidden = True ' Столбец AL
				.Columns(39).EntireColumn.Hidden = True ' Столбец AM
				.Columns(40).EntireColumn.Hidden = True ' Столбец AN
				.Columns(41).EntireColumn.Hidden = True ' Столбец AO
				.Columns(42).EntireColumn.Hidden = True ' Столбец AP
				.Columns(43).EntireColumn.Hidden = True ' Столбец AQ
				.Columns(44).EntireColumn.Hidden = True ' Столбец AR
				.Columns(45).EntireColumn.Hidden = True ' Столбец AS
				.Columns(46).EntireColumn.Hidden = True ' Столбец AT
				.Columns(47).EntireColumn.Hidden = True ' Столбец AU
				.Columns(48).EntireColumn.Hidden = True ' Столбец AV
			End With
			If (oSheet.Range("FL1").Value = 0) Then
				With Worksheets(oSheet.Name)
					.Columns("W").EntireColumn.Hidden  = True	
					.Columns("X").EntireColumn.Hidden  = True	
					.Columns("Y").EntireColumn.Hidden  = True	
					.Columns("Z").EntireColumn.Hidden  = True	
					.Columns("AA").EntireColumn.Hidden = True	
					.Columns("AB").EntireColumn.Hidden = True	
					.Columns("AC").EntireColumn.Hidden = True						
				End With
			End If 
			If  (oSheet.Range("FK1").Value = "DOCUMENTS_REESTR_SDR") Then
				With Worksheets(oSheet.Name)
					.Columns("W").EntireColumn.Show  = True
					.Columns("X").EntireColumn.Show  = True	
					.Columns("Y").EntireColumn.Show  = True	
					.Columns("Z").EntireColumn.Show  = True	
					.Columns("AA").EntireColumn.Show = True	
					.Columns("AB").EntireColumn.Show = True	
					.Columns("AC").EntireColumn.Show = True						
				End With
			End If
		End If
		
	Next oSheet
End Sub

Sub ChangeToolbar(ByVal nMode As Integer)
    Dim bFound As Boolean, oBar As Object

    If Application.Visible And Application.ScreenUpdating And Application.DisplayAlerts Then
        bFound = False
        For Each oBar In Application.CommandBars
            If oBar.Name = "RROExcelClient" Then bFound = True
        Next
        If bFound Then
            With Application.CommandBars("RROExcelClient").Controls(1)
                Select Case nMode
                Case 1:
                    If .FaceId = 342 Then .FaceId = 352
                Case 2:
                    If .FaceId = 352 Then .FaceId = 342
                End Select
            End With
        End If
    End If
End Sub

Function ExistsNames(ByVal oBook As Workbook, ByVal cName As String) As Boolean
    Dim i As Integer
    
    For i = 1 To oBook.Names.Count
        If oBook.Names(i).Name = cName Then
            ExistsNames = True
            Exit Function
        End If
    Next
    ExistsNames = False
End Function

Function GetADOVersion() As Double
    Dim ADO, ADOVersion As Double

    On Error GoTo ErrorAdo
    
    Set ADO = CreateObject("ADODB.Connection")
    ADOVersion = VBA.Val(ADO.Version)
    Set ADO = Nothing
    
    On Error GoTo 0
    GoTo ExitFunc

ErrorAdo:
    On Error GoTo 0
    ADOVersion = 0
    
ExitFunc:
    GetADOVersion = ADOVersion
End Function

Function GetChar(ByVal nVal As Long, ByVal nCount As Long)
    Dim cRet As String, cTran As String, nX As Long
		
    On Error GoTo ErrMsg
        
    cTran = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ"
    cRet = ""
    
    nX = nVal
    Do While nX <> 0
        cRet = VBA.Mid$(cTran, (nX Mod 36) + 1, 1) + cRet
        nX = VBA.Int(nX / 36)
    Loop
    
    If VBA.LEN(cRet) > nCount Then
        GetChar = VBA.Space$(nCount)
    Else
        GetChar = VBA.IIf(VBA.LEN(cRet) < nCount, VBA.String(nCount - VBA.LEN(cRet), "0"), "") + cRet
    End If
    Exit Function

ErrMsg:
    Call VBA.MsgBox("Номер: " + VBA.str(Err.Number) + VBA.vbNewLine _
        + "Источник: " + Err.Source + VBA.vbNewLine _
        + "Описание: " + Err.Description, VBA.vbOKOnly + VBA.vbCritical, "Ошибка")
End Function

Function GetCode(ByVal str As String) As String
    Dim p As String, char As Byte, i As Integer
    
    str = VBA.Mid(str, 3, VBA.LEN(str) - 2)
    p = ""
    For i = 1 To VBA.LEN(str)
        char = VBA.Asc(VBA.Mid(str, i, 1))
        p = p + VBA.Chr((char + 7) Xor 7)
    Next i
    
    GetCode = p
End Function

Function GetExcelVersion() As String
    Dim nVersion As Double, cVersion As String
    
    nVersion = VBA.Val(Application.Version)
    Select Case nVersion
    Case 12
        cVersion = "2007"
    Case 11
        cVersion = "2003"
    Case 10
        cVersion = "XP (2002)"
    Case 9
        cVersion = "2000"
    Case Else
        cVersion = "версия " + VBA.str(nVersion)
    End Select
    GetExcelVersion = "Microsoft Office Excel " + cVersion
End Function

Function GetLocalInfo(ByVal nInfo As Long) As String
    Dim cBuffer As String, nRet As String
    
    cBuffer = VBA.String$(256, 0)
    nRet = GetLocaleInfo(LOCALE_USER_DEFAULT, nInfo, cBuffer, VBA.LEN(cBuffer))
    
    GetLocalInfo = VBA.Trim(VBA.IIf(nRet > 0, VBA.Left$(cBuffer, nRet - 1), ""))
End Function

Function GetRangeFormat(ByVal cFormat As String, ByVal nLen As Long) As String
    Dim cResult As String

    Select Case VBA.UCase(cFormat)
    Case "STRING"
        cResult = "@"
    Case "DATE"
        cResult = "dd.mm.yyyy"
    Case "NUMBER"
        cResult = "#,##0" + VBA.IIf(nLen > 0, "." + VBA.String(nLen, "0"), "")
    Case Else
        cResult = ""
    End Select

    GetRangeFormat = cResult
End Function

Function GetShortPath(ByVal cFileName As String) As String
    Dim nRes As Long, cPath As String
    
    cPath = VBA.String$(255, 0)
    nRes = GetShortPathName(cFileName, cPath, 254)
    GetShortPath = VBA.Left$(cPath, nRes)
End Function

Sub GetSplitSign(ByVal cLen As String, ByRef cSign As String, ByRef nLen As Long)
    Dim i As Integer

    cSign = VBA.Replace(cLen, " ", "")
    If VBA.LEN(cSign) > 0 Then
        i = 0
        Do While VBA.Mid(cSign, i + 1, 1) = "<" Or VBA.Mid(cSign, i + 1, 1) = ">" Or VBA.Mid(cSign, i + 1, 1) = "="
            i = i + 1
        Loop
        If i > 0 Then
            nLen = VBA.Val(VBA.Mid(cSign, i + 1))
            cSign = VBA.Left(cSign, i)
        Else
            nLen = VBA.Val(cSign)
            cSign = ""
        End If
    Else
        nLen = 0
        cSign = ""
    End If
End Sub

Function GetStrParam(ByVal cParam As String, ByVal nParam As Integer, Optional ByVal cPart As String = "#") As String
    Dim nPos1 As Integer, nPos2 As Integer, i As Long
    
    nPos1 = 0
    i = 1
    While i < nParam
        nPos1 = VBA.InStr(nPos1 + 1, cParam, cPart)
        If nPos1 = 0 Then
            GetStrParam = ""
            Exit Function
        End If
        i = i + 1
    Wend
    nPos2 = VBA.InStr(nPos1 + 1, cParam, cPart)
    nPos2 = VBA.IIf(nPos2 = 0, VBA.LEN(cParam), nPos2 - 1)
    If nPos2 > nPos1 Then
        GetStrParam = VBA.Mid(cParam, nPos1 + 1, nPos2 - nPos1)
    Else
        GetStrParam = ""
    End If
End Function

Sub InitProtectSheets(oSheet As Worksheet)
    Dim nVal As Long, cWord As String
	If (oSheet.ProtectContents) Then
		Exit Sub ' лист уже защищен - уходим
	End If
	VBA.Randomize
    nVal = VBA.Int(VBA.Rnd() * 100000) * 10000 + VBA.Int(VBA.Rnd() * 100000)
    cWord = GetChar(nVal, 10)
    Call ScriptSet(oSheet, "protect_word", cWord)
End Sub

Sub InitToolbar(ByVal cMode As String)
    Dim bFound As Boolean, oToolbar As Object

    bFound = False
    For Each oToolbar In Application.CommandBars
        If oToolbar.Name = "RROExcelClient" Then bFound = True
    Next
    If bFound Then Application.CommandBars("RROExcelClient").Delete

    Set oToolbar = CommandBars.Add(Name:="RROExcelClient", Position:=msoBarTop, Temporary:=True)
    With oToolbar.Controls.Add(Type:=msoControlButton)
        .FaceId = 342
        .Style = msoButtonIcon
        .Caption = "Сохранить данные на сервере"
        .OnAction = "RROExcelClientInit.SaveDataToServer"
    End With
    
    oToolbar.Enabled = True
    oToolbar.Visible = True
    Application.Calculation = xlCalculationAutomatic
    Application.ActiveWorkbook.Saved = True
    Application.ThisWorkbook.Saved = True
End Sub

Sub InitToolbarRedo(ByVal cMode As String)
    Call InitToolbar(cMode)
End Sub
Sub InitGlobals(conn As Object, Optional strDOC_TYPE As String)
	Dim con As ADODB.Connection
	Dim rsSet As ADODB.Recordset
	Dim strSQL As String
	Set con = conn
		
	strSQL = "SELECT dbo.obj_id('" + strDOC_TYPE + "')"
	Set rsSet = conn.Execute(strSQL)
	DOCUMENTS_REESTR_CODE = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('DICTIONARY_NORM_DOC')"
	Set rsSet = conn.Execute(strSQL)
	DICTIONARY_NORM_DOC = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_PREC_DOC')"
	Set rsSet = conn.Execute(strSQL)
	DICTIONARY_PREC_DOC = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_SODERG_RO')"
	Set rsSet = conn.Execute(strSQL)
	DICTIONARY_SODERG_RO = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_UTOCH_FIELD')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_UTOCH_FIELD = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_SECTOR_BUDGET')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_SECTOR_BUDGET = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('DICTIONARY_MEMO_RO')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_MEMO_RO = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('COLUMN_REESTR_RO_EXPLAIN')"
	Set rsSet = conn.Execute(strSQL)		
	COLUMN_REESTR_RO_EXPLAIN = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('COLUMN_REESTR_RO_RATE')"
	Set rsSet = conn.Execute(strSQL)		
	COLUMN_REESTR_RO_RATE = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('DICTIONARY_GROUP_RO')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_GROUP_RO = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('PLAN_SUM_REESTR_RO')"
	Set rsSet = conn.Execute(strSQL)		
	PLAN_SUM_REESTR_RO = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('ACTUAL_SUM_REESTR_RO')"
	Set rsSet = conn.Execute(strSQL)		
	ACTUAL_SUM_REESTR_RO = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_BK_IST')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_BK_IST = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_DEPARTMENT')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_DEPARTMENT = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_DEPARTMENT')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_DEPARTMENT = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_DIVISION')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_DIVISION = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_DIVISION')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_DIVISION = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_TARGET_ITEM')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_TARGET_ITEM = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_TARGET_ITEM')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_TARGET_ITEM = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_EXPEND')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_EXPEND = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_EXPEND')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_EXPEND = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_ITEM')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_ITEM = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_ITEM')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_ITEM = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_ADD_BK')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_ADD_BK = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_ADD_BK')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_ADD_BK = rsSet.Fields(0)
	
	strSQL = "SELECT dbo.obj_id('REFERENCE_KBK_LOCAL')"
	Set rsSet = conn.Execute(strSQL)		
	REFERENCE_KBK_LOCAL = rsSet.Fields(0)

	strSQL = "SELECT dbo.obj_id('DICTIONARY_KBK_LOCAL')"
	Set rsSet = conn.Execute(strSQL)		
	DICTIONARY_KBK_LOCAL = rsSet.Fields(0)
End Sub
Sub SaveDataToServer()
	Dim bResult As Boolean
	Dim strErrorReason As String
	strErrorReason = ""
	
	If (ActiveSheet.Name LIKE "РРО*" Or ActiveSheet.Name LIKE "Черновик РРО*" Or ActiveSheet.Name LIKE "76Н*") then
		bResult = SaveRRO(ActiveSheet, strErrorReason)
		If (bResult) Then 
			MsgBox "Данные успешно сохранены", vbOkOnly + vbINformation, ActiveSheet.Name
		Else
			MsgBox "Данные не сохранены" + vbCrLf + strErrorReason, vbOkOnly + vbCritical, ActiveSheet.Name
		End If
	End If
	
	If (ActiveSheet.Name LIKE "НПА*") Then 
		Dim rroSheet As Worksheet
		Set rroSheet = GetSheet(ThisWorkbook, "РРО (")
		bResult = SaveNewNPA(rroSheet, ActiveSheet, strErrorReason)
		If (bResult) Then 
			MsgBox "Данные успешно сохранены", vbOkOnly + vbINformation, ActiveSheet.Name
		Else
			MsgBox "Данные не сохранены" + vbCrLf + strErrorReason, vbOkOnly + vbCritical, ActiveSheet.Name
		End If
	End If
	
End Sub

Function GetSheet(oBook As Workbook, sheetName As String) As Worksheet
    Dim oSheet As Worksheet
    
    For Each oSheet In oBook.Sheets
		If (oSheet.Name LIKE ("*" + sheetName + "*")) Then
			Set GetSheet = oSheet
			Exit Function
		End If
	Next oSheet
	GetSheet = Nothing
End Function

Function SaveNewNPA(rroSheet As Worksheet, oSheet As Worksheet, strErrorReason As String) As Boolean
	Dim strError As String
	SaveNewNPA = False
	strError = "На листе отсутствуют:" + vbCrlf
	
	If IsEmpty(rroSheet.Range(RROGlobal.SERVER_NAME).Value) Then 
		strError = strError + "имя сервера БД" + vbCrlf
	End If
	
	If IsEmpty(rroSheet.Range(RROGlobal.DATABASE_NAME).Value) Then 
		strError = strError + "имя базы данных" + vbCrlf
	End If
	
	If IsEmpty(rroSheet.Range(RROGLobal.USER_NAME).Value) Then 
		strError = strError + "имя пользователя БД" + vbCrlf
	End If
	
	If (strError <> "На листе отсутствуют:" + vbCrlf) Then
		strErrorReason = strError
		SaveNewNPA = False
	Else
		Dim strServerName As String
		strServerName = rroSheet.Range(RROGlobal.SERVER_NAME).Value
		
		Dim strUserName As String
		strUserName = rroSheet.Range(RROGLobal.USER_NAME).Value
		
		Dim strDataBaseName As String
		strDataBaseName = rroSheet.Range(RROGlobal.DATABASE_NAME).Value
		
		Dim LinkCorr As Long
		LinkCorr = rroSheet.Range(RROGlobal.CORR_LINK).Value
		
		Dim conn As ADODB.Connection
		Dim rsSet As ADODB.Recordset
		Dim nCounter As Integer ' счетчик цикла
		On Error Goto Err_
		Dim strConn As String
		Dim strSQL As String
		
		Dim strPassword As String
		strPassword = ""
		
		If (PasswordEnterForm.Visible = False Or PasswordEnterForm Is Nothing) Then 
			PasswordEnterForm.Caption = "Укажите пароль для пользователя " +  strUserName
			PasswordEnterForm.Show 1
			strPassword = PasswordEnterForm.Tag
		End If
		
		If (strPassword = "rro_excel_client.xlt") Then 
			SaveNewNPA = False
			Exit Function
		End If

		Set conn = New ADODB.Connection
		strConn = "Provider=SQLOLEDB;"
		strConn = strConn + "DATA SOURCE=" + strServerName + ";INITIAL CATALOG=" + strDataBaseName
		strConn = strConn & "; User ID=" + strUserName + ";Password=" +strPassword + ";"
		conn.ConnectionString = strConn
		conn.Open
		
		Call InitGlobals(conn, "DOCUMENTS_REESTR_RO") ' второй параметр "фиктивный", для этого вызова он не нужен 
		
		Dim rBegin as Range 
		Dim rEnd As Range
		Set rBegin = FindRange(oSheet.Columns(RROGlobal.COD_STR), "гр.1", True)
		
		Dim NewLinkCD As Long ' линк новой строки в CREDIT_DOC
		NewLinkCD = 0
		
		if (rBegin is Nothing) then
			strErrorReason = "Отсутствует маркер 'гр.1' в столбце " + RROGlobal.COD_STR
			SaveNewNPA = False
			Exit Function
		End If
		
		Set rEnd = FindRange(oSheet.Columns(RROGlobal.LINK_CD), "Добавить", True)		
		If (rEnd Is Nothing) Then
			SaveNewNPA = False
			strErrorReason = "Отсутствует маркер 'Добавить' в столбце " + RROGlobal.LINK_CD
			conn.Close
			Exit Function				
		Else
			Dim UserUID As Long
			strSQL = "SELECT UID FROm S_USERS WHERE LOGINAME = '" + strUserName + "'"
			Set rsSet = conn.Execute(strSQL)
			UserUID = rsSet.Fields(0) ' UID пользователя из S_USERS
			
			Dim strCorrName As String
			If (LinkCorr = 0) Then
				strCorrName = rroSheet.Range("I4").Value
				strSQL = "SELECT LINK FROM S_CORR WHERE SNAME LIKE '" + strCorrName + "%'"
				Set rsSet = conn.Execute(strSQL)
				LinkCorr = rsSet.Fields(0)
			End If
			For nCounter = rBegin.Row + 1 To rEnd.Row - 1
				If (oSheet.Range(RROGlobal.NPA_NEW + CStr(nCounter)).Value = 2) Then
					' проверка на наличие НПА в справочнике
					Dim strDate As String
					strDate = CStr(oSheet.Range(RROGlobal.NPA_DATE + CStr(nCounter)).Value)
					strSQL = "SELECT COUNT(*) FROM CREDIT_DOC CD WHERE CD.NUMBER = '" _
					+ CStr(oSheet.Range(RROGlobal.NPA_CODE + CStr(nCounter)).Value) + "' AND " _
					+ " CD.DATE = convert(datetime,'" +  strDate _
					+ "',104) AND OBJECT = " + CStr(DICTIONARY_NORM_DOC)
					Dim nCountNPA AS Long
					Set rsSet = conn.Execute(strSQL)
					nCountNPA = rsSet.Fields(0)
					
					If (nCountNPA > 0) Then
						oSheet.Range(RROGlobal.NPA_CODE + CStr(nCounter)).Select
						If (MsgBox("Строка " + Cstr(nCounter) + vbCrlf + "НПА с таким номером и датой уже есть в справочнике!" + vbCrlf + "Все равно сохранить?", vbOKCancel+vbQuestion + vbDefaultButton2, oSheet.Name) = vbCancel) Then
							strErrorReason = "НПА в строке " + Cstr(nCounter) + " уже есть в справочнике."
							SaveNewNPA = False
							Exit Function
						End if
					End If
				
					' добавление НПА в CREDIT_DOC и OBJECT_CREDIT
					strSQL = "INSERT INTO CREDIT_DOC(NUMBER, DATE, NAME, OBJECT, ROW_ID, USERS) VALUES('" _
					+ CStr(oSheet.Range(RROGlobal.NPA_CODE + CStr(nCounter)).Value) + "', convert(datetime, '" _ 
					+ strDate + "',104), '" _
					+ CStr(oSheet.Range(RROGlobal.NPA_NAME + CStr(nCounter)).Value) + "'," _
					+ CStr(DICTIONARY_NORM_DOC) + ", NEWID(), " _
					+ CStr(UserUID) + ")"
					Set rsSet = conn.Execute(strSQL)
					NewLinkCD = rsSet.Fields(0)
					strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, DATE_LAST, CREDIT, REQ, CORR)" _
					+ " VALUES(" + Cstr(NewLinkCD) + ", " + CStr(DICTIONARY_NORM_DOC) + "," + CStr(DICTIONARY_NORM_DOC) + "," _
					
					If (oSheet.Range(RROGlobal.NPA_DATE_B + CStr(nCounter)).Value <> "") Then 
						strDate = oSheet.Range(RROGlobal.NPA_DATE_B + CStr(nCounter)).Value
						strSQL = strSQL + "convert(datetime, '" + strDate + "',104), "
					Else 
						strSQL = strSQL + "NULL, "
					End If
					
					If (oSheet.Range(RROGlobal.NPA_SROK + CStr(nCounter)).Value <> "") Then
						strDate = oSheet.Range(RROGlobal.NPA_SROK + CStr(nCounter)).Value
						strSQL = strSQL + "convert(datetime, '" + strDate + "',104), "
					Else 
						strSQL = strSQL + "NULL, "
					End If
					
					If (oSheet.Range(RROGlobal.NPA_TYPE + CStr(nCounter)).Value <> "") Then 
						strSQL = strSQL + CStr(oSheet.Range(RROGlobal.NPA_TYPE + CStr(nCounter)).Value) + "," 
					Else 
						strSQL = strSQL + "NULL, "
					End If
					
					If (oSheet.Range(RROGlobal.NPA_LEVEL + CStr(nCounter)).Value <> "") Then 
						strSQL = strSQL + CStr(oSheet.Range(RROGlobal.NPA_LEVEL + CStr(nCounter)).Value) + "," 
					Else 
						strSQL = strSQL + "NULL, "
					End If
					
					strSQL = strSQL + Cstr(LinkCorr) + ")"
					conn.Execute(strSQL)
					
					oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value = NewLinkCD
					oSheet.Range(RROGLobal.LINK_CD + CStr(nCounter)).Font.ColorIndex = 2 'ThemeColor = xlThemeColorDark1
					'oSheet.Range(RROGLobal.LINK_CD + CStr(nCounter)).Font.TintAndShade = 0						
					oSheet.Range(RROGlobal.NPA_NEW + CStr(nCounter)).Value = ""
				End If
			Next nCounter
			SaveNewNPA = True		
		End If
		conn.Close
		Exit Function
		
	Err_:
		strErrorReason = Err.Description
		SaveNewNPA = False		
	End If
End Function

Function SaveRRO(oSheet As Worksheet, strErrorReason As String) as Boolean
	Dim strError As String
	SaveRRO = False
	strError = "На листе отсутствуют:" + vbCrlf
	If IsEmpty(oSheet.Range(RROGlobal.SERVER_NAME).Value) Then 
		strError = strError + "имя сервера БД" + vbCrlf
	End If
	
	If IsEmpty(oSheet.Range(RROGlobal.DATABASE_NAME).Value) Then 
		strError = strError + "имя базы данных" + vbCrlf
	End If
	
	If IsEmpty(oSheet.Range(RROGLobal.USER_NAME).Value) Then 
		strError = strError + "имя пользователя БД" + vbCrlf
	End If
	
	If IsEmpty(oSheet.Range(RROGlobal.DOC_TYPE).Value)  Then
		strError = strError + "код объекта документа" + vbCrlf
	End If
	
	If (strError <> "На листе отсутствуют:" + vbCrlf) Then
		strErrorReason = strError
		SaveRRO = False
	Else
		Dim strServerName As String
		strServerName = oSheet.Range(RROGlobal.SERVER_NAME).Value
		
		Dim strUserName As String
		strUserName = oSheet.Range(RROGLobal.USER_NAME).Value
		
		Dim strDataBaseName As String
		strDataBaseName = oSheet.Range(RROGlobal.DATABASE_NAME).Value
		
		Dim LinkCorr As Long
		LinkCorr = oSheet.Range(RROGlobal.CORR_LINK).Value
		
		Dim CurrYear As Long
		CurrYear = oSheet.Range(RROGlobal.YEAR).Value
		
		Dim strDoc_Type As String
		strDoc_Type = Trim(oSheet.Range(RROGlobal.DOC_TYPE).Value)
		
		Dim conn As ADODB.Connection
		Dim rsSet As ADODB.Recordset
		Dim nCounter As Integer ' счетчик цикла
		On Error Goto Err_
		Dim strConn As String
		Dim strSQL As String
		Dim sumKBK As KBK
		Dim strPassword As String
		strPassword = ""
		
		If (PasswordEnterForm.Visible = False Or PasswordEnterForm Is Nothing) Then 
			PasswordEnterForm.Caption = "Укажите пароль для пользователя " +  strUserName
			PasswordEnterForm.Show 1
			strPassword = PasswordEnterForm.Tag
		End If
		
		If (strPassword = "rro_excel_client.xlt") Then 
			SaveRRO = False
			Exit Function
		End If
		
		Set conn = New ADODB.Connection
		strConn = "Provider=SQLOLEDB;"
		strConn = strConn + "DATA SOURCE=" + strServerName + ";INITIAL CATALOG=" + strDataBaseName
		strConn = strConn & "; User ID=" + strUserName + ";Password=" +strPassword + ";"
		conn.ConnectionString = strConn
		conn.Open
		
		Call InitGlobals(conn, strDoc_Type)
		
		Dim rBegin as Range 
		Dim rEnd As Range
		Set rBegin = FindRange(oSheet.Columns(RROGlobal.COD_STR), "гр.0", True)
		
		Dim LinkOC As Long ' линк строки в OBJECT_CREDIT
		Dim NewLinkCD As Long ' линк новой строки в CREDIT_DOC
		
		if (rBegin is Nothing) then
			strErrorReason = "Отсутствует маркер 'гр.0' в столбце " + RROGlobal.COD_STR
			SaveRRO = False
			Exit Function
		End If
		
		Set rEnd = FindRange(oSheet.Columns(RROGlobal.LINK_CD), "Добавить", True)
		If (rEnd Is Nothing) Then
			SaveRRO = False
			strErrorReason = "Отсутствует маркер 'Добавить' в столбце " + RROGlobal.LINK_CD
			conn.Close
			Exit Function				
		Else
			For nCounter = rBegin.Row + 1 To rEnd.Row - 1
				If (oSheet.Range(RROGlobal.POLN_CHANGE + CStr(nCounter)).Value = 1) Then
					SaveRRO = SavePoln(conn, _
							   oSheet.Range(RROGlobal.POLN_LINK + CStr(nCounter)).MergeArea.Cells(1, 1).Value, _
							   oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
							   strUserName, _
							   False, 0)
				ElseIf (oSheet.Range(RROGlobal.POLN_CHANGE + CStr(nCounter)).Value = 2) Then
					NewLinkCD = 0
					SaveRRO = SavePoln(conn, _
							oSheet.Range(RROGlobal.POLN_LINK + CStr(nCounter)).MergeArea.Cells(1, 1).Value, _
							NewLinkCD, _
							strUserName, _
							True, LinkCorr)
					oSheet.Range(RROGlobal.POLN_CHANGE + CStr(nCounter)).Value = ""
					oSheet.Range(RROGLobal.LINK_CD + CStr(nCounter)).MergeArea.Cells(1, 1).Value = NewLinkCD
					oSheet.Range(RROGLobal.LINK_CD + CStr(nCounter)).MergeArea.Cells(1, 1).Font.ColorIndex = 2 'ThemeColor = xlThemeColorDark1
					'oSheet.Range(RROGLobal.LINK_CD + CStr(nCounter)).MergeArea.Cells(1, 1).Font.TintAndShade = 0						
				End If
				
				If (oSheet.Range(RROGlobal.NPA1_CHANGE + CStr(nCounter)).Value = 1) Then ' отредактированный НПА
					LinkOC = oSheet.Range(RROGlobal.LINK_OC1 + CStr(nCounter)).Value
					SaveRRO = SaveNPA(conn, oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
								  oSheet.Range(RROGlobal.LINK_NORM1 + CStr(nCounter)).Value,  _
								  oSheet.Range(RROGlobal.NPA1_OLD_LINK+CStr(nCounter)).Value, _
								  LinkOC, _
								  oSheet.Range(RROGlobal.VIP_N1 + CStr(nCounter)).Value, _
								  False)
					oSheet.Range(RROGlobal.LINK_OC1 + CStr(nCounter)).Value = LinkOC ' возвращаем на лист линк новой выписки
					oSheet.Range(RROGlobal.NPA1_CHANGE + CStr(nCounter)).Value = "" ' сбрасываем признак изменения НПА
				ElseIf (oSheet.Range(RROGlobal.NPA1_CHANGE + CStr(nCounter)).Value = 2) Then ' новый НПА
					LinkOC = oSheet.Range(RROGlobal.LINK_OC1 + CStr(nCounter)).Value
					SaveRRO = SaveNPA(conn, oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
								  oSheet.Range(RROGlobal.LINK_NORM1 + CStr(nCounter)).Value,  _
								  oSheet.Range(RROGlobal.NPA1_OLD_LINK+CStr(nCounter)).Value, _
								  LinkOC, _
								  oSheet.Range(RROGlobal.VIP_N1 + CStr(nCounter)).Value, _
								  True)
					oSheet.Range(RROGlobal.LINK_OC1 + CStr(nCounter)).Value = LinkOC ' возвращаем на лист линк новой выписки
					oSheet.Range(RROGlobal.NPA1_CHANGE + CStr(nCounter)).Value = "" ' сбрасываем признак изменения НПА
					End If
					
				If (oSheet.Range(RROGlobal.NPA2_CHANGE + CStr(nCounter)).Value = 1) Then
					LinkOC = oSheet.Range(RROGlobal.LINK_OC2 + CStr(nCounter)).Value
					SaveRRO = SaveNPA(conn, oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
								  oSheet.Range(RROGlobal.LINK_NORM2 + CStr(nCounter)).Value,  _
								  oSheet.Range(RROGlobal.NPA2_OLD_LINK+CStr(nCounter)).Value, _
								  LinkOC, _
								  oSheet.Range(RROGlobal.VIP_N2 + CStr(nCounter)).Value, _
								  False)
					oSheet.Range(RROGlobal.LINK_OC2 + CStr(nCounter)).Value = LinkOC
					oSheet.Range(RROGlobal.NPA2_CHANGE + CStr(nCounter)).Value = ""
				ElseIf (oSheet.Range(RROGlobal.NPA2_CHANGE + CStr(nCounter)).Value = 2) Then ' новый НПА
					LinkOC = oSheet.Range(RROGlobal.LINK_OC2 + CStr(nCounter)).Value
					SaveRRO = SaveNPA(conn, oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
								  oSheet.Range(RROGlobal.LINK_NORM2 + CStr(nCounter)).Value,  _
								  oSheet.Range(RROGlobal.NPA2_OLD_LINK+CStr(nCounter)).Value, _
								  LinkOC, _
								  oSheet.Range(RROGlobal.VIP_N2 + CStr(nCounter)).Value, _
								  True)
					oSheet.Range(RROGlobal.LINK_OC2 + CStr(nCounter)).Value = LinkOC ' возвращаем на лист линк новой выписки
					oSheet.Range(RROGlobal.NPA2_CHANGE + CStr(nCounter)).Value = "" ' сбрасываем признак изменения НПА
				End If
				
				If (oSheet.Range(RROGlobal.NPA3_CHANGE + CStr(nCounter)).Value = 1) Then
					LinkOC = oSheet.Range(RROGlobal.LINK_OC3 + CStr(nCounter)).Value
					SaveRRO = SaveNPA(conn, oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
								  oSheet.Range(RROGlobal.LINK_NORM3 + CStr(nCounter)).Value,  _
								  oSheet.Range(RROGlobal.NPA3_OLD_LINK+CStr(nCounter)).Value, _
								  LinkOC, _
								  oSheet.Range(RROGlobal.VIP_N3 + CStr(nCounter)).Value, _
								  False)
					oSheet.Range(RROGlobal.LINK_OC3 + CStr(nCounter)).Value = LinkOC
					oSheet.Range(RROGlobal.NPA3_CHANGE + CStr(nCounter)).Value = ""
				ElseIf (oSheet.Range(RROGlobal.NPA3_CHANGE + CStr(nCounter)).Value = 2) Then ' новый НПА
					LinkOC = oSheet.Range(RROGlobal.LINK_OC3 + CStr(nCounter)).Value
					SaveRRO = SaveNPA(conn, oSheet.Range(RROGlobal.LINK_CD + CStr(nCounter)).Value, _
								  oSheet.Range(RROGlobal.LINK_NORM3 + CStr(nCounter)).Value,  _
								  oSheet.Range(RROGlobal.NPA3_OLD_LINK+CStr(nCounter)).Value, _
								  LinkOC, _
								  oSheet.Range(RROGlobal.VIP_N3 + CStr(nCounter)).Value, _
								  True)
					oSheet.Range(RROGlobal.LINK_OC3 + CStr(nCounter)).Value = LinkOC ' возвращаем на лист линк новой выписки
					oSheet.Range(RROGlobal.NPA3_CHANGE + CStr(nCounter)).Value = "" ' сбрасываем признак изменения НПА
				End If
				
				If (oSheet.Range(RROGlobal.KBK_CHANGE + CStr(nCounter)).Value = 1) Then 
					LinkOC = oSheet.Range(RROGlobal.LINK_OC + CStr(nCounter)).Value
					Dim LinkCD As Long
					LinkCD = oSheet.Range(RROGLobal.LINK_CD + CStr(nCounter)).MergeArea.Cells(1, 1).Value
					Dim LinkKBK As Long
					LinkKBK = oSheet.Range(RROGLobal.KBK_LINK + CStr(nCounter)).Value
					With sumKBK
						.CDEP = oSheet.Range(RROGLobal.CDEP + CStr(nCounter)).Value
						.CDIV = oSheet.Range(RROGLobal.CDIV + CStr(nCounter)).Value
						.CTGT = oSheet.Range(RROGLobal.CTGT + CStr(nCounter)).Value
						.CEXP = oSheet.Range(RROGLobal.CEXP + CStr(nCounter)).Value
						.CITEM = oSheet.Range(RROGLobal.CITEM + CStr(nCounter)).Value
						.CADD_BK = oSheet.Range(RROGLobal.CADD_BK + CStr(nCounter)).Value
						.CLCL = oSheet.Range(RROGLobal.CLCL + CStr(nCounter)).Value
						If (oSheet.Range(CHECK_THOUSAND).Value = 1) Then
						.S_FACT0 = CDbl(oSheet.Range(RROGLobal.S_FACT0 + CStr(nCounter)).Value) * 1000
						.S_PLAN0 = CDbl(oSheet.Range(RROGLobal.S_PLAN0 + CStr(nCounter)).Value) * 1000
						.S_PLAN1 = CDbl(oSheet.Range(RROGLobal.S_PLAN1 + CStr(nCounter)).Value) * 1000
						.S_PLAN2 = CDbl(oSheet.Range(RROGLobal.S_PLAN2 + CStr(nCounter)).Value) * 1000
						.S_PLAN3 = CDbl(oSheet.Range(RROGLobal.S_PLAN3 + CStr(nCounter)).Value) * 1000
						.S_PLAN4 = CDbl(oSheet.Range(RROGLobal.S_PLAN4 + CStr(nCounter)).Value) * 1000
						Else
						.S_FACT0 = CDbl(oSheet.Range(RROGLobal.S_FACT0 + CStr(nCounter)).Value)
						.S_PLAN0 = CDbl(oSheet.Range(RROGLobal.S_PLAN0 + CStr(nCounter)).Value)
						.S_PLAN1 = CDbl(oSheet.Range(RROGLobal.S_PLAN1 + CStr(nCounter)).Value)
						.S_PLAN2 = CDbl(oSheet.Range(RROGLobal.S_PLAN2 + CStr(nCounter)).Value)
						.S_PLAN3 = CDbl(oSheet.Range(RROGLobal.S_PLAN3 + CStr(nCounter)).Value)
						.S_PLAN4 = CDbl(oSheet.Range(RROGLobal.S_PLAN4 + CStr(nCounter)).Value)
						End If
					End With
					If (Len(sumKBK.CDEP) <> 0) Then
						sumKBK.CDEP = String(3 - Len(sumKBK.CDEP), "0") + sumKBK.CDEP
						sumKBK.CDEP = Replace(sumKBK.CDEP, Chr(160), "", 1, -1)
					End If
					If (Len(sumKBK.CDIV) <> 0) Then
						sumKBK.CDIV = String(4 - Len(sumKBK.CDIV), "0") + sumKBK.CDIV
						sumKBK.CDIV = Replace(sumKBK.CDIV, Chr(160), "", 1, -1)
					End If
					If (Len(sumKBK.CTGT) <> 0) Then
						sumKBK.CTGT = String(7 - Len(sumKBK.CTGT), "0") + sumKBK.CTGT
						sumKBK.CTGT = Replace(sumKBK.CTGT, Chr(160), "", 1, -1)
					End If
					If (Len(sumKBK.CEXP) <> 0) Then
						sumKBK.CEXP = String(3 - Len(sumKBK.CEXP), "0") + sumKBK.CEXP
						sumKBK.CEXP = Replace(sumKBK.CEXP, Chr(160), "", 1, -1)
					End If
					If (Len(sumKBK.CITEM) <> 0) Then
						sumKBK.CITEM = String(3 - Len(sumKBK.CITEM), "0") + sumKBK.CITEM
						sumKBK.CITEM = Replace(sumKBK.CITEM, Chr(160), "", 1, -1)
					End If
					If (Len(sumKBK.CADD_BK) <> 0) Then
						sumKBK.CADD_BK = Replace(sumKBK.CADD_BK, Chr(160), "", 1, -1)
					End If
					If (Len(sumKBK.CLCL) <> 0) Then
						sumKBK.CLCL = Replace(sumKBK.CLCL, Chr(160), "", 1, -1)
					End If
					
					SaveRRO = SaveSum(conn, LinkCD, LinkOC, LinkKBK, sumKBK, CurrYear, strErrorReason)				
					If (SaveRRO = False) Then
						strErrorReason = strErrorReason + vbCrlf + "Строка: " + Cstr(nCounter)
						oSheet.Range(STR_BK + Cstr(nCounter)).Select
					Else
						oSheet.Range(KBK_CHANGE + CStr(nCounter)).Value = ""
						oSheet.Range(KBK_LINK + Cstr(nCounter)).Value = LinkKBK
						oSheet.Range(LINK_OC + Cstr(nCounter)).Value = LinkOC
					End If
				End If
			Next nCounter
		End If
			
		conn.Close
		Exit Function
	Err_:
		strErrorReason = Err.Description
		SaveRRO = False
	End If
End Function
Function SaveSum(conn As Object, LinkCD As Long, LinkOC As Long, LinkKBK As Long, summKBK As KBK, CurrYear As Long, strErrorReason As String) As Boolean
	Dim con As ADODB.Connection
	Dim rsSet As ADODB.Recordset
	Dim strSQL As String
	Set con = conn
	On Error Goto Err_
	
	If (LinkKBK = 0) Then ' новая строка с суммами
		LinkKBK = GetKBKLink(con, summKBK, strErrorReason)
		If (LinkKBK = 0) Then ' получили 0 в качестве линка, уходим
			SaveSum = False
			Exit Function
		Else ' получили линк новой комбинации БК
			If  (summKBK.S_FACT0 <> 0) Then
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(ACTUAL_SUM_REESTR_RO) + ", " _
				+ "'" + CStr(CurrYear - 1) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_FACT0), ",", ".") + ", NEWID())"
				con.Execute(strSQL)
			End If
		
			If  (summKBK.S_PLAN0 > 0) Then
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ "'" + CStr(CurrYear - 1) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN0), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)
			End If
		
			If  (summKBK.S_PLAN1 > 0) Then
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ "'" + CStr(CurrYear) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN1), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)			
			End If
		
			If  (summKBK.S_PLAN2 > 0) Then
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ "'" + CStr(CurrYear + 1) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN2), ",", ".") + ", NEWID())"
				con.Execute(strSQL)				
			End If
		
			If  (summKBK.S_PLAN3 > 0) Then
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ "'" + CStr(CurrYear + 2) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN3), ",", ".") + ", NEWID())"
				con.Execute(strSQL)
			End If
		
			If  (summKBK.S_PLAN4 > 0) Then
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ "'" + CStr(CurrYear + 3) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN4), ",", ".") + ", NEWID())"
				con.Execute(strSQL)
			End If
			SaveSum = True
			Exit Function
		End If
	Else ' редактируем строку с суммами
	' необходимо проверить - вдруг суммы какого-то года нет в БД, но ее добавили в клиенте
		Dim nSumCount As Long
		nSumCount = 0
		Dim strSumMethod As String ' линк методики расчета сумм из поля CREDIT
		
		strSQL = "SELECT ISNULL((SELECT TOP 1 CREDIT FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT IN (" + CStr(ACTUAL_SUM_REESTR_RO) + "," + Cstr(PLAN_SUM_REESTR_RO) + ")" _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) + "), 0)"
		Set rsSet = con.Execute(strSQL)
		
		If (Not rsSet.BOF) Then
			strSumMethod = CStr(rsSet.Fields(0))
			if (strSumMethod = "0") Then strSumMethod = "NULL"
		Else
			strSumMethod = "NULL"
		End If
		
		If  (summKBK.S_FACT0 <> 0) Then
			strSQL = "SELECT COUNT(*) FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT = " + CStr(ACTUAL_SUM_REESTR_RO) _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) _
			+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + " + 1 = 0)"
			Set rsSet = con.Execute(strSQL)
			nSumCount = rsSet.Fields(0)
			If (nSumCount > 0) Then
				strSQL = "UPDATE OBJECT_CREDIT SET SUMMA = " + Replace(CStr(summKBK.S_FACT0), ",", ".") _
				+ " WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
				+ " AND OBJECT_DICT = " + CStr(ACTUAL_SUM_REESTR_RO) _
				+ " AND KBK = " + CStr(LinkKBK) _
				+ " AND LINK_UP = " + CStr(LinkCD) _
				+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + " + 1 = 0)"
				con.Execute(strSQL)
			Else
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(ACTUAL_SUM_REESTR_RO) + ", " _
				+ strSumMethod + ", " _
				+ "'" + CStr(CurrYear - 1) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_FACT0), ",", ".") + ", NEWID())"
				con.Execute(strSQL)
			End If
			nSumCount = 0
		End If
		
		If  (summKBK.S_PLAN0 <> 0) Then
			strSQL = "SELECT COUNT(*) FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) _
			+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + " + 1 = 0)"
			Set rsSet = con.Execute(strSQL)
			nSumCount = rsSet.Fields(0)
			If (nSumCount > 0) Then
				strSQL = "UPDATE OBJECT_CREDIT SET SUMMA = " + Replace(CStr(summKBK.S_PLAN0), ",", ".") _
				+ " WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
				+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
				+ " AND KBK = " + CStr(LinkKBK) _
				+ " AND LINK_UP = " + CStr(LinkCD) _
				+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + " + 1 = 0)"
				con.Execute(strSQL)
			Else
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT,  DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ strSumMethod + ", " _
				+ "'" + CStr(CurrYear - 1) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN0), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)			
			End If
			nSumCount = 0
		End If
		
		If  (summKBK.S_PLAN1 <> 0) Then
			strSQL = "SELECT COUNT(*) FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) _
			+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 0)"
			Set rsSet = con.Execute(strSQL)
			nSumCount = rsSet.Fields(0)
			If (nSumCount > 0) Then		
				strSQL = "UPDATE OBJECT_CREDIT SET SUMMA = " + Replace(CStr(summKBK.S_PLAN1), ",", ".") _
				+ " WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
				+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
				+ " AND KBK = " + CStr(LinkKBK) _
				+ " AND LINK_UP = " + CStr(LinkCD) _
				+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 0)"
				con.Execute(strSQL)
			Else 
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ strSumMethod + ", " _
				+ "'" + CStr(CurrYear) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN1), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)						
			End If
			nSumCount = 0				
		End If
		
		If  (summKBK.S_PLAN2 <> 0) Then
			strSQL = "SELECT COUNT(*) FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) _
			+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 1)"
			Set rsSet = con.Execute(strSQL)
			nSumCount = rsSet.Fields(0)
			If (nSumCount > 0) Then		
				strSQL = "UPDATE OBJECT_CREDIT SET SUMMA = " + Replace(CStr(summKBK.S_PLAN2), ",", ".") _
				+ " WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
				+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
				+ " AND KBK = " + CStr(LinkKBK) _
				+ " AND LINK_UP = " + CStr(LinkCD) _
				+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 1)"
				con.Execute(strSQL)
			Else 
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ strSumMethod + ", " _
				+ "'" + CStr(CurrYear + 1) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN2), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)						
			End If
			nSumCount = 0				
		End If
		
		If  (summKBK.S_PLAN3 <> 0) Then
			strSQL = "SELECT COUNT(*) FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) _
			+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 2)"
			Set rsSet = con.Execute(strSQL)
			nSumCount = rsSet.Fields(0)
			If (nSumCount > 0) Then		
				strSQL = "UPDATE OBJECT_CREDIT SET SUMMA = " + Replace(CStr(summKBK.S_PLAN3), ",", ".") _
				+ " WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
				+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
				+ " AND KBK = " + CStr(LinkKBK) _
				+ " AND LINK_UP = " + CStr(LinkCD) _
				+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 2)"
				con.Execute(strSQL)
			Else 
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ strSumMethod + ", " _
				+ "'" + CStr(CurrYear + 2) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN3), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)						
			End If
			nSumCount = 0				
		End If
		
		If  (summKBK.S_PLAN4 <> 0) Then
			strSQL = "SELECT COUNT(*) FROM OBJECT_CREDIT WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
			+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
			+ " AND KBK = " + CStr(LinkKBK) _
			+ " AND LINK_UP = " + CStr(LinkCD) _
			+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 3)"
			Set rsSet = con.Execute(strSQL)
			nSumCount = rsSet.Fields(0)
			If (nSumCount > 0) Then		
				strSQL = "UPDATE OBJECT_CREDIT SET SUMMA = " + Replace(CStr(summKBK.S_PLAN4), ",", ".") _
				+ " WHERE OBJECT = " + CStr(DOCUMENTS_REESTR_CODE) _
				+ " AND OBJECT_DICT = " + CStr(PLAN_SUM_REESTR_RO) _
				+ " AND KBK = " + CStr(LinkKBK) _
				+ " AND LINK_UP = " + CStr(LinkCD) _
				+ " AND (DATEPART(YYYY, DATE_FIRST) - " + CStr(CurrYear) + "= 3)"
				con.Execute(strSQL)
			Else 
				strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT, DATE_FIRST, KBK, SUMMA, ROW_ID) VALUES(" _
				+ Cstr(LinkCD) + ", " _
				+ CStr(DOCUMENTS_REESTR_CODE) + ", " _
				+ CStr(PLAN_SUM_REESTR_RO) + ", " _
				+ strSumMethod + ", " _
				+ "'" + CStr(CurrYear + 3) + "', " _
				+ CStr(LinkKBK) + ", " _
				+ Replace(CStr(summKBK.S_PLAN4), ",", ".")+ ", NEWID())"
				con.Execute(strSQL)						
			End If
			nSumCount = 0				
		End If
		SaveSum = True
		Exit Function
	End If
Err_:
	strErrorReason = Err.Description
	SaveSum = False
End Function
Function GetKBKLink(conn As Object, summKBK As KBK, strErrorReason As String) As Long
	Dim con As ADODB.Connection
	Dim rsSet As ADODB.Recordset
	Dim strSQL As String
	Set con = conn
	
	strSQL = "SELECT LINK FROM V_DICTIONARY_BK_IST WHERE "
	If (summKBK.CDEP <> "") Then
		strSQL = strSQL + " CDEP = '" + summKBK.CDEP + "'"
	Else
		strSQL = strSQL + " CDEP IS NULL"
	End If
	
	If (summKBK.CDIV <> "") Then
		strSQL = strSQL + " AND CDIV = '" + summKBK.CDIV + "'"
	Else
		strSQL = strSQL + " AND CDIV IS NULL"
	End If
	
	If (summKBK.CTGT <> "") Then
		strSQL = strSQL + " AND CTGT = '" + summKBK.CTGT + "'"
	Else
		strSQL = strSQL + " AND CTGT IS NULL"
	End If
	
	If (summKBK.CEXP <> "") Then
		strSQL = strSQL + " AND CEXP = '" + summKBK.CEXP + "'"
	Else
		strSQL = strSQL + " AND CEXP IS NULL"
	End If
	
	If (summKBK.CITEM <> "") Then
		strSQL = strSQL + " AND CITEM = '" + summKBK.CITEM + "'"
	Else
		strSQL = strSQL + " AND CITEM IS NULL"
	End If

	If (summKBK.CADD_BK <> "") Then
		strSQL = strSQL + " AND CADD_BK = '" + summKBK.CADD_BK + "'"
	Else
		strSQL = strSQL + " AND CADD_BK IS NULL"
	End If

	If (summKBK.CLCL <> "") Then
		strSQL = strSQL + " AND CLCL = '" + summKBK.CLCL + "'"
	Else
		strSQL = strSQL + " AND CLCL IS NULL"
	End If
	
	Set rsSet = con.Execute(strSQL)
	if (Not rsSet.BOF) Then
		GetKBKLink = rsSet.Fields(0)
	Else
		Dim ROWID As String
		Dim linkKBK As Long
		linkKBK = 0
		Dim linkDEP As Long
		linkDEP = 0
		Dim linkDIV As Long
		linkDIV = 0
		Dim linkTGT As Long
		linkTGT = 0
		Dim linkEXP As Long
		linkEXP = 0
		Dim linkITEM As Long
		linkITEM = 0
		Dim linkADD_BK As Long
		linkADD_BK = 0
		Dim linkLOCAL_BK As Long
		linkLOCAL_BK = 0
		Dim strError As String
		strError = ""
		
		If (summKBK.CDEP <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CDEP + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_DEPARTMENT)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkDEP = rsSet.Fields(0)
			Else
				strError = "В справочнике отсутствует ведомство с кодом " + summKBK.CDEP
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function
			End If
		End If
		
		If (summKBK.CDIV <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CDIV + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_DIVISION)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkDIV = rsSet.Fields(0)
			Else
				strError = "В справочнике отсутствует подраздел с кодом " + summKBK.CDIV
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function
			End If
		End If
		
		If (summKBK.CTGT <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CTGT + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_TARGET_ITEM)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkTGT = rsSet.Fields(0)
			Else
				strError = "В справочнике отсутствует целевая статья с кодом " + summKBK.CTGT
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function
			End If
		End If
		
		If (summKBK.CEXP <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CEXP + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_EXPEND)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkEXP = rsSet.Fields(0)
			Else
				strError = "В справочнике отсутствует вид расхода с кодом " + summKBK.CEXP
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function				
			End If
		End If
		
		If (summKBK.CITEM <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CITEM + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_ITEM)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkITEM = rsSet.Fields(0)
			Else
				strError = "В справочнике отсутствует КОСГУ с кодом " + summKBK.CITEM
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function				
			End If
		End If

		If (summKBK.CADD_BK <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CADD_BK + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_ADD_BK)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkADD_BK = rsSet.Fields(0)
			Else
				strError = "В справочнике отсутствует доп.класс. с кодом " + summKBK.CADD_BK
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function				
			End If
		End If

		If (summKBK.CLCL <> "") Then
			strSQL = "SELECT LINK FROM S_KBK WHERE CODE = '" + summKBK.CLCL + "'" _
					+ " AND OBJECT = " + CStr(DICTIONARY_KBK_LOCAL)
			Set rsSet = con.Execute(strSQL)
			If (Not rsSet.BOF) Then 
				linkLOCAL_BK = rsSet.Fields(0)
			Else
				strError =  "В справочнике отсутствует рег.класс. с кодом " + summKBK.CLCL
				GetKBKLink = 0
				strErrorReason = strError
				Exit Function				
			End If
		End If
		
		strSQL = "SELECT NEWID()"
		Set rsSet = con.Execute(strSQL)
		ROWID = rsSet.Fields(0)
		ROWID = Mid(ROWID, 2, Len(ROWID)-1)
		ROWID = Mid(ROWID, 1, Len(ROWID)-1)
		
		strSQL = "DECLARE @ROW_ID uniqueidentifier" _
		+ " SET @ROW_ID = CAST( '" + ROWID + "' as uniqueidentifier)" _
		+ " INSERT INTO S_KBK(CODE, OBJECT, ROW_ID) VALUES(" _
		+ "LEFT(NEWID(), 20), "+ CStr(DICTIONARY_BK_IST) + ", @ROW_ID)"
		Set rsSet = con.Execute(strSQL)
		
		strSQL = "SELECT LINK FROM S_KBK WHERE ROW_ID = '" + ROWID + "'"
		Set rsSet = con.Execute(strSQL)
		linkKBK = rsSet.Fields(0)
		GetKBKLink = linkKBK		
		
		If (linkDEP <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkDEP) + "," + CStr(REFERENCE_DEPARTMENT) +")"
			con.Execute(strSQL)
		End If
		
		If (linkDIV <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkDIV) + "," + CStr(REFERENCE_DIVISION) +")"
			con.Execute(strSQL)
		End If
		
		If (linkTGT <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkTGT) + "," + CStr(REFERENCE_TARGET_ITEM) +")"
			con.Execute(strSQL)
		End If
		
		If (linkEXP <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkEXP) + "," + CStr(REFERENCE_EXPEND) +")"
			con.Execute(strSQL)
		End If
		
		If (linkITEM <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkITEM) + "," + CStr(REFERENCE_ITEM) +")"
			con.Execute(strSQL)
		End If
		
		If (linkADD_BK <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkADD_BK) + "," + CStr(REFERENCE_ADD_BK) +")"
			con.Execute(strSQL)
		End If
		
		If (linkLOCAL_BK <> 0) Then
			strSQL = "INSERT INTO T_KBK(REF1, REF2, OBJECT) VALUES(" _
				+ CStr(linkKBK) + "," + CStr(linkLOCAL_BK) + "," + CStr(REFERENCE_KBK_LOCAL) +")"
			con.Execute(strSQL)
		End If
	End If
End Function

Function SavePoln(conn As Object, PolnLink As Long, LinkCD As Long, strUserName As String, NewRecord As Boolean, LinkCorr As Long) As Boolean ' сохраняем в БД расходное полномочие
	Dim con As ADODB.Connection
	Dim rsSet As ADODB.Recordset
	Dim strSQL as String
	Set con = conn
	
	If (NewRecord) Then ' создаем новое РО в CREDIT_DOC и связанные с ним строки в OBJECT_CREDIT
		strSQL = "SELECT NAME FROM CREDIT_DOC WHERE LINK = " + CStr(PolnLink)
		Set rsSet = con.Execute(strSQL)
		Dim NewRROName As String
		NewRROName = rsSet.Fields(0) ' Новое имя РО = имя полномочия
		
		Dim UserUID As Long
		strSQL = "SELECT UID FROm S_USERS WHERE LOGINAME = '" + strUserName + "'"
		Set rsSet = con.Execute(strSQL)
		UserUID = rsSet.Fields(0) ' UID пользователя из S_USERS
		
		Dim strCorrName As String
		
		strCorrName = RROGlobal.oCurrentSheet.Range("I4").Value
		strSQL = "SELECT LINK FROM S_CORR WHERE SNAME LIKE '" + strCorrName + "%'"
		Set rsSet = con.Execute(strSQL)
		LinkCorr = rsSet.Fields(0)
		
		' вычисление номера для нового РО
		Dim NewRRONumber As String ' новый номер РО (строка вида Р-Х.ХХХ)
		Dim nNewRRONumber As Long  ' новый номер РО (последние три цифры)
		nNewRRONumber = 0
		NewRRONumber = "Р-1." ' номер по умолчанию
		' определяем трехзначный код для номера РО		
		strSQL = "SELECT MAX(CAST(RIGHT(NUMBER, 3) AS INT)) AS NUMBER FROM CREDIT_DOC WHERE LINK IN " _
				+"(SELECT LINK_UP FROM OBJECT_CREDIT WHERE CORR ="+ CStr(LinkCorr) + ") AND OBJECT=" _
				+ CStr(DOCUMENTS_REESTR_CODE) _
				+" AND LEFT(NUMBER, 4) LIKE 'Р-1.%' GROUP BY NUMBER ORDER BY NUMBER DESC"
		
		Set rsSet = con.Execute(strSQL)
		
		If (Not rsSet.BOF) Then
			nNewRRONumber = rsSet.Fields(0)	
		Else
			nNewRRONumber = 0
		End If
		
		nNewRRONumber = nNewRRONumber + 1
		' пребразовываем номер РО к виду 00X (дополняем слева нулями)
		strSQL = " declare @str varchar(3) " _
		+ "declare @intmax int" _
		+ " set @intmax = " + CStr(nNewRRONumber) _
		+ " set @str = CAST(@intmax AS varchar(3)) " _
		+ " select @str = REPLICATE('0',3-LEN(@str))+@str " _
		+ " select @str "
		Set rsSet = con.Execute(strSQL)
		NewRRONumber = NewRRONumber + rsSet.Fields(0)
		
		' вставляем шапку РО в CREDIT_DOC
		strSQL = "INSERT INTO CREDIT_DOC(NUMBER, DATE, LINK_CLASS, NAME, OBJECT, USERS) VALUES(" _ 
		+ "'" + NewRRONumber +"'," + "dbo.GETWORKDATE()" + "," + "NULL,'" + NewRROName + "'," _
		+ CStr(DOCUMENTS_REESTR_CODE) + "," + CStr(UserUID) + ")"
		Set rsSet = con.Execute(strSQL)
		LinkCD = rsSet.Fields(0)
		
		' вставляем примечание РО
		strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT) VALUES(" _
		+ CStr(LinkCD) +"," + CStr(DOCUMENTS_REESTR_CODE) + "," +CStr(DICTIONARY_MEMO_RO) + ")"
		con.Execute(strSQL)
		' вставляем обоснование РО
		strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT) VALUES(" _
		+ CStr(LinkCD) +"," + CStr(DOCUMENTS_REESTR_CODE) + "," +CStr(COLUMN_REESTR_RO_EXPLAIN) + ")"
		con.Execute(strSQL)
		' вставляем показатель РО
		strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT) VALUES(" _
		+ CStr(LinkCD) +"," + CStr(DOCUMENTS_REESTR_CODE) + "," +CStr(COLUMN_REESTR_RO_RATE) + ")"
		con.Execute(strSQL)
		' вставляем категорию РО
		strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT) VALUES(" _
		+ CStr(LinkCD) +"," + CStr(DOCUMENTS_REESTR_CODE) + "," +CStr(DICTIONARY_GROUP_RO) + ")"
		con.Execute(strSQL)		
		' вставляем строку расходного обязательство в OBJECT_CREDIT
		strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, ORDERS, CORR) VALUES(" _
		+ CStr(LinkCD) + "," + CStr(DOCUMENTS_REESTR_CODE) + "," + CStr(DOCUMENTS_REESTR_CODE) + ", 1," _
		+ CStr(LinkCorr) + ")"
		con.Execute(strSQL)
		' вставляем расходное полномочие в OBJECT_CREDIT
		strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT, OBJECT_DICT, CREDIT) VALUES(" _
		+ CStr(LinkCD) + "," +CStr(DOCUMENTS_REESTR_CODE)+ "," + CStr(DICTIONARY_SODERG_RO) + "," + CStr(PolnLink) + ")"
		con.Execute(strSQL)
	Else ' обновляем линк на полномочие в OBJECT_CREDIT
		strSQL = "UPDATE OBJECT_CREDIT SET CREDIT = " + CStr(PolnLink) _
		+ " WHERE OBJECT_CREDIT.LINK_UP = " + CStr(LinkCD) + " AND OBJECT_CREDIT.OBJECT_DICT="+CStr(DICTIONARY_SODERG_RO)
		con.Execute(strSQL) 
	End If
	
	SavePoln = True
End Function

Function SaveNPA(conn As Object, LinkCD As Long, LinkNPA As Long, LinkOldNPA As Long, ByRef LinkOC As Long, Ufields As String, NewNPA As Boolean) As Boolean
	Dim con As ADODB.Connection
	Dim rsSet As ADODB.Recordset
	Dim i As Integer ' счетчик цикла
	Dim OBJECT_DICT as Long
	Dim CREDIT As Long  ' линк на шапку выписки в CREDIT_DOC
	Dim LINK_CLASS As Long ' линк на НПА из выписки в CREDIT_DOC
	Dim ROWID As String ' уникальный код строки
	Dim strSQL As String
	Dim LinkVIP As Long ' линк созданной выписки
	Dim arrFields() As Variant  ' массив уточняющих полей
	Dim TypeFieldLink As Long ' линк на тип поля в S_NOTE
	Set con = conn
	SaveNPA = False

	strSQL = "SELECT NEWID()"
	Set rsSet = con.Execute(strSQL)
	ROWID = rsSet.Fields(0)
	ROWID = Mid(ROWID, 2, Len(ROWID)-1)
	ROWID = Mid(ROWID, 1, Len(ROWID)-1)
	
	If (NewNPA) Then ' если НПА новый
			' добавляем в CREDIT_DOC строку новой выписки
			strSQL = "DECLARE @ROW_ID uniqueidentifier" _
			+ " SET @ROW_ID = CAST( '" + ROWID + "' as uniqueidentifier)" _
			+ " INSERT INTO CREDIT_DOC(LINK_CLASS, OBJECT, ROW_ID) VALUES(" _
			+ CStr(LinkNPA) + " , " + CStr(DICTIONARY_PREC_DOC) + " ,@ROW_ID)"
			con.Execute(strSQL)

			' получаем линк только что добавленной выписки
			strSQL = "SELECT LINK FROM CREDIT_DOC WHERE ROW_ID = '" + ROWID + "'"
			Set rsSet = con.Execute(strSQL)
			LinkVIP = rsSet.Fields(0)
			
			' добавляем строку с выпиской в OBJECT_CREDIT
			strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT_DICT, OBJECT, ROW_ID, CREDIT) VALUES(" _
			+ CStr(LinkCD) + "," + CStr(DICTIONARY_PREC_DOC) + "," + CStr(DOCUMENTS_REESTR_CODE) + ",'" + ROWID + "'," _
			+ CStr(LinkVIP) + ")"
			con.Execute(strSQL)
			
			' получаем линк только что добавленной строки 
			strSQL = "SELECT LINK FROM OBJECT_CREDIT WHERE ROW_ID = '" + ROWID + "'"
			Set rsSet = con.Execute(strSQL)
			LinkOC = rsSet.Fields(0) ' по ссылке возвращаем линк строки в OBJECT_CREDIT
			
			arrFields = StrSplit(UFields) ' парсим строку с полями в массив
			If (UBound(arrFields)<> -1) Then
				For i = LBound(arrFields) To UBound(arrFields)
					strSQL = "SELECT LINK FROM S_NOTE WHERE VALUE LIKE '%"  + arrFields(i, 0) + "%'"
					Set rsSet = con.Execute(strSQL)
					TypeFieldLink = rsSet.Fields(0)
					strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT_DICT, OBJECT, REQ, VALUE) VALUES(" _
					+ CStr(LinkVIP) + "," + CStr(DICTIONARY_UTOCH_FIELD) + "," + CStr(DICTIONARY_PREC_DOC) + "," _
					+ CStr(TypeFieldLink) + ",'" + arrFields(i, 1) + "')"
					con.Execute(strSQL)
				Next
			End If
	Else ' заменяем старый НПА
		' получаем ссылку на шапку НПА в CREDIT_DOC из поля CREDIT в OBJECT_CREDIT
		strSQL = "SELECT CREDIT, OBJECT_DICT FROM OBJECT_CREDIT OC WHERE OC.LINK = " + CStr(LinkOC)
		Set rsSet = con.Execute(strSQL)
		CREDIT = rsSet.Fields(0)
		OBJECT_DICT = rsSet.Fields(1)
		
		If (OBJECT_DICT = DICTIONARY_PREC_DOC) Then 
			strSQL = "SELECT LINK_CLASS FROM CREDIT_DOC CD WHERE CD.LINK = " + CStr(CREDIT)
			Set rsSet = con.Execute(strSQL)
			LINK_CLASS = rsSet.Fields(0)
			
			' удаляем строки уточняющих полей из OBJECT_CREDIT
			strSQL = "DELETE OBJECT_CREDIT WHERE OBJECT_DICT = " + CStr(DICTIONARY_UTOCH_FIELD) _
			+ " AND OBJECT = " + CStr(DICTIONARY_PREC_DOC) + " AND LINK_UP = " + CStr(CREDIT)
			con.Execute(strSQL)
			
			' удаляем строку с выпиской из OBJECT_CREDIT
			strSQL = "DELETE OBJECT_CREDIT WHERE OBJECT_DICT = " + CStr(DICTIONARY_PREC_DOC) _
					+" AND LINK = " + CStr(LinkOC)
			con.Execute(strSQL)		

			' добавляем в CREDIT_DOC строку новой выписки
			strSQL = "DECLARE @ROW_ID uniqueidentifier" _
			+ " SET @ROW_ID = CAST( '" + ROWID + "' as uniqueidentifier)" _
			+ " INSERT INTO CREDIT_DOC(LINK_CLASS, OBJECT, ROW_ID) VALUES(" _
			+ CStr(LinkNPA) + " , " + CStr(DICTIONARY_PREC_DOC) + " ,@ROW_ID)"
			con.Execute(strSQL)

			' получаем линк только что добавленной выписки
			strSQL = "SELECT LINK FROM CREDIT_DOC WHERE ROW_ID = '" + ROWID + "'"
			Set rsSet = con.Execute(strSQL)
			LinkVIP = rsSet.Fields(0)
			
			' добавляем строку с выпиской в OBJECT_CREDIT
			strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT_DICT, OBJECT, ROW_ID, CREDIT) VALUES(" _
			+ CStr(LinkCD) + "," + CStr(DICTIONARY_PREC_DOC) + "," + CStr(DOCUMENTS_REESTR_CODE) + ",'" + ROWID + "'," _
			+ CStr(LinkVIP) + ")"
			con.Execute(strSQL)
			
			' получаем линк только что добавленной строки 
			strSQL = "SELECT LINK FROM OBJECT_CREDIT WHERE ROW_ID = '" + ROWID + "'"
			Set rsSet = con.Execute(strSQL)
			LinkOC = rsSet.Fields(0) ' по ссылке возвращаем линк строки в OBJECT_CREDIT
			
			arrFields = StrSplit(UFields) ' парсим строку с полями в массив
			If (UBound(arrFields)<> -1) Then
				For i = LBound(arrFields) To UBound(arrFields)
					strSQL = "SELECT LINK FROM S_NOTE WHERE VALUE LIKE '%"  + arrFields(i, 0) + "%'"
					Set rsSet = con.Execute(strSQL)
					TypeFieldLink = rsSet.Fields(0)
					strSQL = "INSERT INTO OBJECT_CREDIT(LINK_UP, OBJECT_DICT, OBJECT, REQ, VALUE) VALUES(" _
					+ CStr(LinkVIP) + "," + CStr(DICTIONARY_UTOCH_FIELD) + "," + CStr(DICTIONARY_PREC_DOC) + "," _
					+ CStr(TypeFieldLink) + ",'" + arrFields(i, 1) + "')"
					con.Execute(strSQL)
				Next
			End If
		ElseIf (OBJECT_DICT = DICTIONARY_NORM_DOC) Then
			strSQL = "UPDATE OBJECT_CREDIT SET CREDIT = " + CStr(LinkNPA) + " WHERE LINK = " + CStr(LinkOC)
			con.Execute(strSQL)
		End If
		
		SaveNPA = True
	End If
End Function

Sub CreateReference(nParam As String)
On Error Goto Err_
	Dim IDL As ITEMIDLIST
	Dim idlstr As Long
	Dim sPath As String
	idlstr = SHGetSpecialFolderLocation(0, 38, IDL)
	sPath = VBA.Space$(260)
	idlstr = SHGetPathFromIDList(ByVal IDL.mkid.cb, sPath)
	sPath = VBA.Left(VBA.Trim(sPath), VBA.Len(VBA.Trim(sPath)) - 1)
	If sPath = "" Then sPath = "C:\Program Files"
	sPath = sPath + "\Common Files\System\ado\msado15.dll"
    Application.VBE.VBProjects(Application.ThisWorkbook.VBProject.Name).References.AddFromFile(sPath)
	Exit Sub
Err_:
	MsgBox Err.Description, vbOKOnly + vbCritical, ActiveSheet.Name
End Sub

Public Function FindRange(Source As Range, SearchString As String, FirstEntry As Boolean) As Range
    Dim fCell As Range
    Dim topAddress As String
    Dim firstAddress As String
    Dim lastAddress As String
    Dim fullAddress As String
    
    If (FirstEntry) Then
        With Source
            Set fCell = .Find(SearchString, LookIn:=xlValues)
            If (Not fCell Is Nothing) Then
                firstAddress = fCell.Address
                lastAddress = fCell.Address
            End If
        End With
    Else
        With Source
                Set fCell = .Find(SearchString, LookIn:=xlValues)
                If Not fCell Is Nothing Then
                    topAddress = fCell.Address
                    firstAddress = fCell.Address
                    Do
                        lastAddress = fCell.Address
                        Set fCell = .FindNext(fCell)
                        If (fCell Is Nothing) Then
                            firstAddress = topAddress
                            Exit Do
                        Else
                            If (fCell.Address <> topAddress) Then
                                firstAddress = fCell.Address
                            End If
                        End If
                    Loop While (Not fCell Is Nothing And fCell.Address <> topAddress)
                End If
        End With
    End If
    fullAddress = firstAddress + ":" + lastAddress
    If (fullAddress = ":") Then
        Set FindRange = Nothing
    Else
        Set FindRange = Range(fullAddress)
    End If
End Function

Sub PutInfo(Optional ByVal cInfo As String = "", Optional ByVal cFileTxt As String = "", Optional ByVal cFileHtm As String = "" _
        , Optional ByVal nMode As Integer = 0, Optional ByVal nLevel As Integer = 0, Optional ByVal bStatus As Boolean = False _
        , Optional ByVal cHtmSpanStyle As String = "", Optional ByVal nModeTxt As Long = 0)
    Dim cSpace As String, nCnt As Long, cOutInfo As String
    
    If cFileTxt <> "" Then
        If nMode = 0 Then
            Open cFileTxt For Output As #1
        Else
            Open cFileTxt For Append As #1
        End If
        
        If nModeTxt = 0 Then
            cOutInfo = cInfo
            If nLevel > 0 Then
                cOutInfo = VBA.IIf(nLevel = 1, VBA.vbNewLine, "") + VBA.String((nLevel - 1) * 4, " ") + VBA.Replace(cInfo, VBA.Chr(10), VBA.Chr(10) + VBA.String((nLevel - 1) * 4, " "))
            End If
        Else
            cSpace = ""
            For nCnt = 1 To (nLevel - 1) * 4
                cSpace = cSpace + "&nbsp;"
            Next nCnt
            
            cOutInfo = cInfo
            If nLevel > 0 Then
                If nLevel = 1 Then
                    cOutInfo = "<H1>" + cSpace + VBA.Replace(cInfo, VBA.Chr(10), "<BR>" + cSpace) + "</H1>"
                Else
                    cOutInfo = cSpace + VBA.Replace(cInfo, VBA.Chr(10), "<BR>" + cSpace) + "<BR>"
                End If
            End If
            
            If cHtmSpanStyle <> "" Then
                cOutInfo = "<span style=""" + cHtmSpanStyle + """>" + cOutInfo + "</span>"
            End If
        End If
        
        Print #1, cOutInfo
        Close #1
    End If
    
    If cFileHtm <> "" Then
        If nMode = 0 Then
            Open cFileHtm For Output As #1
        Else
            Open cFileHtm For Append As #1
        End If
        
        cSpace = ""
        For nCnt = 1 To (nLevel - 1) * 4
            cSpace = cSpace + "&nbsp;"
        Next nCnt
        
        cOutInfo = cInfo
        If nLevel > 0 Then
            If nLevel = 1 Then
                cOutInfo = "<H1>" + cSpace + VBA.Replace(cInfo, VBA.Chr(10), "<BR>" + cSpace) + "</H1>"
            Else
                cOutInfo = cSpace + VBA.Replace(cInfo, VBA.Chr(10), "<BR>" + cSpace) + "<BR>"
            End If
        End If
        
        If cHtmSpanStyle <> "" Then
            cOutInfo = "<span style=""" + cHtmSpanStyle + """>" + cOutInfo + "</span>"
        End If
        
        Print #1, cOutInfo
        Close #1
    End If
    
    If bStatus Then
        Application.StatusBar = cInfo
    End If
End Sub

Function ReplaceSheetVariable(ByVal oSheet As Worksheet, ByVal cText As String, ByVal cAddr As String) As String
    Dim bLoop As Boolean, nPos1 As Long, nPos2 As Long, cName As String, nIndex As Long, cCurrAddr As String _
        , cReplace As String, cDecimal As String
    
    cDecimal = GetLocalInfo(LOCALE_DECIMAL)
    
    ' глобальные
    bLoop = True
    While VBA.InStr(cText, "[[[") > 0 And bLoop
        nPos1 = VBA.InStr(cText, "[[[")
        If VBA.InStr(nPos1, cText, "]]]") > 0 Then
            nPos2 = VBA.InStr(nPos1, cText, "]]]")
            cName = VBA.Mid(cText, nPos1, nPos2 - nPos1 + 3)
            cReplace = ""
            
            For nIndex = 1 To oSheet.Scripts.Count
                If VBA.InStr(oSheet.Scripts(nIndex).ID, "field_term_") > 0 And VBA.UCase(oSheet.Scripts(nIndex).ScriptText) = VBA.UCase(cName) Then
                    cCurrAddr = VBA.Mid(oSheet.Scripts(nIndex).ID, 1 + VBA.LEN("field_term_"))
                    If VBA.IsDate(oSheet.Range(cCurrAddr).Value) And oSheet.Range(cCurrAddr).NumberFormat = "dd.mm.yyyy" Then
                        cReplace = VBA.Format(oSheet.Range(cCurrAddr).Value, "yyyymmdd")
                    Else
                        cReplace = "" & oSheet.Range(cCurrAddr).Value & ""
                    End If
                    
                    If VBA.IsNumeric(oSheet.Range(cCurrAddr).Value) Then
                        cReplace = VBA.Replace(cReplace, cDecimal, ".")
                    End If
                    
                    Exit For
                End If
            Next nIndex
            
            cReplace = VBA.IIf(cReplace = "", "NULL", cReplace)
            cText = VBA.Replace(cText, cName, cReplace)
        Else
            bLoop = False
        End If
    Wend
    
    ' локальные
    bLoop = True
    While VBA.InStr(cText, "[[") > 0 And bLoop
        nPos1 = VBA.InStr(cText, "[[")
        If VBA.InStr(nPos1, cText, "]]") > 0 Then
            nPos2 = VBA.InStr(nPos1, cText, "]]")
            cName = VBA.Mid(cText, nPos1, nPos2 - nPos1 + 2)
            cReplace = ""
            
            For nIndex = 1 To oSheet.Scripts.Count
                If VBA.InStr(oSheet.Scripts(nIndex).ID, "field_term_") > 0 And VBA.UCase(oSheet.Scripts(nIndex).ScriptText) = VBA.UCase(cName) Then
                    cCurrAddr = VBA.Mid(oSheet.Scripts(nIndex).ID, 1 + VBA.LEN("field_term_"))
                    If oSheet.Range(cCurrAddr).Cells(1, 1).Row = oSheet.Range(cAddr).Cells(1, 1).Row Then
                        If VBA.IsDate(oSheet.Range(cCurrAddr).Value) And oSheet.Range(cCurrAddr).NumberFormat = "dd.mm.yyyy" Then
                            cReplace = VBA.Format(oSheet.Range(cCurrAddr).Value, "yyyymmdd")
                        Else
                            cReplace = "" & oSheet.Range(cCurrAddr).Value & ""
                        End If
                        
                        If VBA.IsNumeric(oSheet.Range(cCurrAddr).Value) Then
                            cReplace = VBA.Replace(cReplace, cDecimal, ".")
                        End If
                        
                        Exit For
                    End If
                End If
            Next nIndex
            
            cReplace = VBA.IIf(cReplace = "", "NULL", cReplace)
            cText = VBA.Replace(cText, cName, cReplace)
        Else
            bLoop = False
        End If
    Wend
    
    ReplaceSheetVariable = cText
End Function

Function ReplaceStr(ByVal lcTemplate As String, ByVal strWhat As String, ByVal strOnWhat As String) As String
    Dim lnStartBegin As Integer, lnStartEnd As Integer, lnLenWhat As Integer
    Dim lcExprLeft As String, lcExprRight As String
    Dim TEMPLATE As String
    
    TEMPLATE = lcTemplate
    While VBA.InStr(1, TEMPLATE, strWhat, vbTextCompare) <> 0
        lnLenWhat = VBA.LEN(strWhat)
        lnStartBegin = VBA.InStr(1, TEMPLATE, strWhat, vbTextCompare)
        lnStartEnd = lnStartBegin + lnLenWhat
        lcExprLeft = VBA.Left(TEMPLATE, lnStartBegin - 1)
        lcExprRight = VBA.Right(TEMPLATE, VBA.LEN(TEMPLATE) - lnStartEnd + 1)
        TEMPLATE = lcExprLeft + strOnWhat + lcExprRight
    Wend
    
    ReplaceStr = TEMPLATE
End Function

Sub ReportSaveExcel()
    Dim aFile() As String, aSheet() As String, aBook() As String, aModule() As String _
        , oCurrApp As Application, cSavePath As String, cFolder As String, i As Long _
        , j As Long, oCurrBook As Workbook, oSaveBook As Workbook, oCurrSheet As Worksheet _
        , oSaveSheet As Worksheet, nIndex As Long, nVisible As Long, nSheet As Long _
        , nFile As Long, cFile As String, bCopyModule As Boolean, bModule As Boolean _
        , nModule As Long, bFile As Boolean, bSaveBook As Boolean, cDecimal As String _
        , oSrcSheet As Worksheet, oDestSheet As Worksheet, nDel As Long, nStart As Long _
        , nEnd As Long, nAnswer As Long, oFolder, cPrefix As String

    On Error GoTo ErrMsg
    cDecimal = GetLocalInfo(LOCALE_DECIMAL)

    Set oCurrApp = Application
    cSavePath = ""
    
    oFolder = oCurrApp.GetSaveAsFilename( _
        InitialFileName:="*.*", _
        FileFilter:="*.*,*.*", _
        Title:="Укажите путь для сохранения ...")
    
    If oFolder = False Then
        Exit Sub
    End If
    
    nIndex = 0
    Do While VBA.InStr(nIndex + 1, oFolder, "\") > 0
        nIndex = VBA.InStr(nIndex + 1, oFolder, "\")
    Loop
    
    If nIndex = 0 Then
        Call VBA.MsgBox("Выгрузка не выполнена. Некорректно указан путь для выгрузки." _
            , VBA.vbOKOnly + VBA.vbExclamation, "Внимание")
        Exit Sub
    End If
    
    cPrefix = VBA.Replace(VBA.Mid(oFolder, nIndex + 1, 10000), " ", "")
    If VBA.InStr(1, cPrefix, ".") > 0 Then
        cPrefix = VBA.Left(cPrefix, VBA.InStr(1, cPrefix, ".") - 1)
    End If
    
    cSavePath = VBA.Left(oFolder, nIndex)
    cFolder = cSavePath
    cSavePath = GetShortPath(cSavePath)
    If VBA.Dir(cSavePath, VBA.vbDirectory) = "" Then Call VBA.MkDir(cSavePath)
    
    nAnswer = VBA.MsgBox("Разбить отчет MS Excel по корреспондентам (ведомствам, администраторам)?" _
                , VBA.vbYesNo + VBA.vbInformation, "Внимание")
    
    oCurrApp.ScreenUpdating = False
    oCurrApp.Calculation = xlCalculationManual
    oCurrApp.DisplayAlerts = False
    
    nSheet = 0
    nFile = 0
    bCopyModule = False
    
    ReDim Preserve aFile(nFile)
    ReDim Preserve aSheet(nSheet)
    ReDim Preserve aBook(nSheet)
    
    Application.StatusBar = "Анализ сохраняемых данных..."
    For Each oCurrBook In oCurrApp.Workbooks
        bModule = False
        For nModule = 1 To oCurrBook.VBProject.VBComponents.Count
            bModule = bModule Or (oCurrBook.VBProject.VBComponents(nModule).Name = "RROExcelClientWork")
        Next nModule
        
        If bModule Then
            If Not bCopyModule Then
                If VBA.Dir(oCurrApp.DefaultFilePath + "\*.bas") <> "" Then VBA.Kill (oCurrApp.DefaultFilePath + "\*.bas")
                nModule = 0
                ReDim Preserve aModule(nModule)
                For nIndex = 1 To oCurrBook.VBProject.VBComponents.Count
                    If oCurrBook.VBProject.VBComponents(nIndex).Type = 1 And oCurrBook.VBProject.VBComponents(nIndex).Name = "RROExcelClientWork" Then
                        nModule = nModule + 1
                        ReDim Preserve aModule(nModule)
                        aModule(nModule) = oCurrApp.DefaultFilePath + "\" + oCurrBook.VBProject.VBComponents(nIndex).Name + ".bas"
                        oCurrBook.VBProject.VBComponents(nIndex).Export (aModule(nModule))
                    End If
                Next nIndex
                bCopyModule = True
            End If
            
            For Each oCurrSheet In oCurrBook.Sheets
                Application.StatusBar = "Анализ сохраняемых данных. Книга: " + oCurrBook.Name + ". Лист: " + oCurrSheet.Name
                If oCurrSheet.Visible = -1 And oCurrSheet.Scripts.Count > 0 Then
                    If nAnswer = 6 Then
                        cFile = oCurrSheet.Name
                        If VBA.InStr(oCurrSheet.Name, "ЛИСТ") > 0 Then
                            cFile = VBA.Left(cFile, VBA.InStr(oCurrSheet.Name, "ЛИСТ") - 1)
                            cFile = VBA.IIf(VBA.Right(cFile, 1) = ".", VBA.Left(cFile, VBA.LEN(cFile) - 1), cFile)
                        End If
                    Else
                        cFile = oCurrBook.Name
                        cFile = VBA.IIf(VBA.InStr(cFile, ".") > 0, VBA.Left(cFile, VBA.InStr(cFile, ".") - 1), cFile)
                    End If
                    
                    If nFile > 0 Then
                        bFile = False
                        For nIndex = 1 To nFile
                            bFile = bFile Or (aFile(nIndex) = cFile)
                        Next nIndex
                        
                        If Not bFile Then
                            nFile = nFile + 1
                            ReDim Preserve aFile(nFile)
                            aFile(nFile) = cFile
                        End If
                    Else
                        nFile = nFile + 1
                        ReDim Preserve aFile(nFile)
                        aFile(nFile) = cFile
                    End If
                    
                    nSheet = nSheet + 1
                    ReDim Preserve aSheet(nSheet)
                    aSheet(nSheet) = oCurrSheet.Name
                    ReDim Preserve aBook(nSheet)
                    aBook(nSheet) = oCurrBook.Name
                End If
            Next oCurrSheet
        End If
        
        oCurrBook.Saved = True
    Next oCurrBook
    
    Application.StatusBar = "Сохранение данных на диск..."
    For i = 1 To nFile
        Set oSaveBook = oCurrApp.Workbooks.Add
        bSaveBook = False
        
        For j = 1 To nSheet
            If (nAnswer = 6 And VBA.InStr(aSheet(j), aFile(i)) > 0) _
                    Or (nAnswer <> 6 And VBA.InStr(aBook(j), aFile(i)) > 0) Then
                bSaveBook = True
                Set oSrcSheet = oCurrApp.Workbooks(aBook(j)).Worksheets(aSheet(j))
                oSrcSheet.Copy After:=oSaveBook.Sheets(1)
                Set oDestSheet = Application.ActiveSheet
                nStart = oSrcSheet.Scripts.Count
                nEnd = oDestSheet.Scripts.Count
                If nStart < nEnd Then
                    For nDel = nEnd To nStart + 1 Step -1
                        Call oDestSheet.Scripts(nDel).Delete
                    Next nDel
                End If
            End If
        Next j
        
        If bSaveBook Then
            If bCopyModule Then
                For nModule = 1 To UBound(aModule)
                    oSaveBook.VBProject.VBComponents.Import (aModule(nModule))
                Next nModule
            End If
            
            For Each oSaveSheet In oSaveBook.Sheets
                If oSaveSheet.ProtectContents = False Then
                    oSaveSheet.Delete
                End If
            Next oSaveSheet
        
            cFile = cPrefix + "_" + aFile(i) + ".xls"
            oCurrApp.Calculation = xlCalculationAutomatic
            If VBA.Val(oCurrApp.Version) >= 12 Then
                oSaveBook.SaveAs Filename:=cSavePath + cFile, FileFormat:=56 'xlExcel8
            Else
                oSaveBook.SaveAs Filename:=cSavePath + cFile
            End If
            oCurrApp.Calculation = xlCalculationManual
        End If
        
        oSaveBook.Saved = True
        oSaveBook.Close SaveChanges:=False
        Application.StatusBar = "Сохранение данных на диск: " + VBA.Replace(VBA.Format(i / nFile, "0%"), cDecimal, ".")
    Next i
    
    For nModule = 1 To UBound(aModule)
        If VBA.Dir(aModule(nModule)) <> "" Then VBA.Kill (aModule(nModule))
    Next nModule

    oCurrApp.StatusBar = False
    oCurrApp.DisplayAlerts = True
    oCurrApp.ScreenUpdating = True
    oCurrApp.Calculation = xlCalculationAutomatic

    Call VBA.MsgBox("Сохранение произведено в каталог:" _
                    + VBA.vbNewLine + cFolder _
                    , VBA.vbOKOnly + VBA.vbInformation, "Внимание")
    Exit Sub

ErrMsg:
    Call VBA.MsgBox("Номер: " + VBA.str(Err.Number) + VBA.vbNewLine _
        + "Источник: " + Err.Source + VBA.vbNewLine _
        + "Описание: " + Err.Description, VBA.vbOKOnly + VBA.vbCritical, "Ошибка")

    If Not oSaveBook Is Nothing Then
        oSaveBook.Saved = True
        oSaveBook.Close SaveChanges:=False
    End If
    
    oCurrApp.StatusBar = False
    oCurrApp.DisplayAlerts = True
    oCurrApp.ScreenUpdating = True
    oCurrApp.Calculation = xlCalculationAutomatic
End Sub

Sub ReportSaveServer(Optional ByVal nModeSave As Long = 0, Optional ByRef nErrorSave As Long = 0 _
        , Optional ByRef cUserLog As String = "", Optional ByRef cSysLog As String = "")
    Dim oSheet As Worksheet, nIndex As Integer, cText As String, cText1 As String _
        , cSql As String, cLogSql As String, cReplace As String, cReplaceText As String _
        , cDecimal As String, nCnt As Integer, cAddr As String, oBook As Workbook _
        , cProperty As String, cTabName As String, cError As String _
        , WshShell, RetVal, cCmd As String, nVal As Long, bErrCtl As Boolean _
        , cLogCtl As String, oRecordSet, cUser As String, nType As Long _
        , cSrv As String, cDb As String, cLogCtlEnd As String, nCounter As Long _
        , cObjCode As String, cFullHtml As String, cHtml As String, cHeader As String _
        , cFooter As String, nResult As Long, bXMLHeader As Boolean, bXMLColumn As Boolean _
        , nFields As Long, nErrorControl As Long, bRecordSetNext As Boolean, cParameters As String _
        , nHeaderResult As Long, bExistsXMLColumn As Boolean, oRecordSetDesc _
        , cHtmlAdd As String, cXmlDesc As String, cXmlData As String, cXsltDesc As String _
        , cXmlFull As String, cXsltFull As String, cGrpFld As String, cGrpDesc As String _
        , cTmpFld As String, cTmpDesc As String, nFldCnt As Long, cTmp As String, cVal As String _
        , cDateFld As String, aGrpFld() As String, oXmlData, oNodeList, oNodeData, oNodeRow _
        , cAttr As String, cXmlVersion As String
    
    ' nErrorSave
    ' 1 - ни один контроль не сработал, данные сохранились - тогда как сейчас есть: данные успешно сохранены
    ' 2 - сработал информационный контроль - имеются не пройденные информационные контроли, данные сохранены
    ' 3 - сработал блокирующий контроль - имеются не пройденные блокирующие контроли, сохранение невозможно
    ' 4 - ошибки при приеме (не связанные с ЦК) - как сейчас - обнаружены ошибки при приеме
    
    On Error GoTo ErrMain
    cDecimal = GetLocalInfo(LOCALE_DECIMAL)
    Set oBook = Application.ActiveWorkbook
    Set WshShell = CreateObject("WScript.Shell")

    nErrorSave = 1
    nErrorControl = 1
    
    cLogCtl = Application.DefaultFilePath + "\save_ctl.htm"
    cUserLog = cLogCtl
    cLogSql = Application.DefaultFilePath + "\save_srv.txt"
    cSysLog = cLogSql
    
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=0, cInfo:="")
    If nModeSave = 0 Then
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, _
            cInfo:="Системный протокол приема от: " + VBA.Format(VBA.Date, "dd.mm.yy") + ", время: " + VBA.Format(VBA.Time, "hh:mm:ss"))
    End If
    
    cXmlVersion = ""
    Set oXmlData = XmlCreateDomDocument(cXmlVersion)
    Set oXmlData = Nothing

    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=1, cInfo:="Информация о клиенте")
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Версия Excel: " + GetExcelVersion)
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Книга Excel: " + oBook.Name)
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Версия ADO: " + VBA.Trim(VBA.str(GetADOVersion())))
    If GetADOVersion() < 2.7 Then
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Внимание! Необходимо проинсталлировать MDAC версии 2.7 или выше!")
        GoTo ErrMain
    End If
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Версия MSXML: " + VBA.IIf(cXmlVersion = "", "неустановленна", cXmlVersion))
    If cXmlVersion = "" Then
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Внимание! Необходимо проинсталлировать MSXML версии 3.0, 4.0 или 6.0!")
        GoTo ErrMain
    End If
    
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=1, cInfo:="Подключение к базе данных")
    cError = ServerConnectOpen(oBook, cSrv, cDb, cUser)
    If cError <> "" Then
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:=cError)
        GoTo ErrMain
    Else
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Сервер: " + cSrv)
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="База данных: " + cDb)
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Пользователь: " + cUser)
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Успешно!")
    End If
    
    If nModeSave = 0 Then
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=1, cInfo:="Подготовка протокола контроля: " + cLogCtl)
        cSql = "execute A_EXEC 'execute dbo.GetHTMLTemplate @cRepHeader = ''<H1>Протокол приема.</H1>'', @cRepFooter = '''', @cParameters = '''''"
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:=cSql)
        
        Set oRecordSet = CreateObject("ADODB.RecordSet")
        oRecordSet.Open cSql, oConnection, 2, 1, 1
        
        cLogCtlEnd = ""
        If Not oRecordSet Is Nothing Then
            If oRecordSet.State = 1 Then
                oRecordSet.MoveFirst
                If Not oRecordSet.EOF Then
                    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, cInfo:=oRecordSet.Fields("HTMLHeader").Value)
                    cLogCtlEnd = oRecordSet.Fields("HTMLFooter").Value
                End If
            End If
        End If
        
        If Not oRecordSet Is Nothing Then
            If oRecordSet.State = 1 Then oRecordSet.Close
        End If
        Set oRecordSet = Nothing
        
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Успешно!")
    End If
    
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cInfo:="Информация о клиенте")
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Версия Excel: " + GetExcelVersion)
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Книга Excel: " + oBook.Name)
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Версия ADO: " + VBA.Trim(VBA.str(GetADOVersion())))
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Версия MSXML: " + cXmlVersion)
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cInfo:="Информация о сервере")
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Сервер: " + cSrv)
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="База данных: " + cDb)
    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Пользователь: " + cUser)
    
    On Error GoTo 0
    On Error GoTo ErrSheet
    For Each oSheet In oBook.Sheets
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, bStatus:=True, cInfo:="Обработка данных страницы: " + oSheet.Name)
        
        Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Анализ объекта данных страницы")
        cObjCode = ScriptGet(oSheet, "object_code")
        If cObjCode <> "" Then
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cInfo:="Код объекта: " + cObjCode)
        Else
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                , cInfo:="Ошибка! Неизвестный объект данных страницы!")
        End If
        
        If oSheet.Scripts.Count > 0 And oSheet.Visible = -1 And cObjCode <> "" Then
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Инициализация сохранения (создание таблицы)")
            cSql = ScriptGet(oSheet, "init_sql")
            If cSql <> "" Then
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="execute A_EXEC '" + cSql + "'")
                oConnection.Execute "execute A_EXEC '" + cSql + "'"
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cInfo:="Успешно!")
            Else
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                    , cInfo:="Ошибка! Отсутствует код инициализации (создание таблицы)!")
                GoTo SkipSheet
            End If
            
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Перенос данных страницы")
            cTabName = ScriptGet(oSheet, "table_name")
            If cTabName = "" Then
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                    , cInfo:="Ошибка! Отсутствует код (наименование) таблицы!")
                GoTo SkipSheet
            End If
            
            nIndex = 0
            cSql = ""
            For nCnt = 1 To oSheet.Scripts.Count
                If VBA.InStr(oSheet.Scripts(nCnt).ID, "alg_term_") > 0 Then
                    cAddr = VBA.Trim(VBA.Mid(oSheet.Scripts(nCnt).ID, 1 + VBA.LEN("alg_term_")))
                    cReplace = VBA.Trim(GetStrParam(oSheet.Scripts(nCnt).ScriptText, 1))
                    cText1 = VBA.Trim(GetStrParam(oSheet.Scripts(nCnt).ScriptText, 2))
                    cText = VBA.Trim(oSheet.Range(cAddr).Text)
                    
                    If VBA.Val(cReplace) > 0 And cText <> cText1 Then
                        cSql = cSql & VBA.Chr(10) & "update OBJECT_VAR_TREE set NAME = left(''" & cText & "'',250) where LINK = (select top 1 LINK_SELF from OBJECT_VAR_TREE where LINK = " & cReplace & ")"
                        nIndex = nIndex + 1
                    End If
                End If
                
                If VBA.InStr(oSheet.Scripts(nCnt).ID, "sql_term_") > 0 Then
                    cAddr = VBA.Mid(oSheet.Scripts(nCnt).ID, 1 + VBA.LEN("sql_term_"))
                    If Not oSheet.Range(cAddr).Locked Then
                        cReplace = VBA.Replace(VBA.Format(VBA.Val(VBA.Trim(VBA.Replace(oSheet.Range(cAddr).Value, cDecimal, "."))), "#.000000"), cDecimal, ".")
                        cReplace = VBA.IIf(cReplace = "", "0.000000", cReplace)
                        cReplaceText = "''" & VBA.Trim(oSheet.Range(cAddr).Value) & "''"
                        
                        If VBA.IsNumeric(oSheet.Range(cAddr).Value) Then
                            cReplaceText = "NULL"
                        Else
                            cReplace = "NULL"
                        End If
                        
                        cText = oSheet.Scripts(nCnt).ScriptText
                        cText = ReplaceSheetVariable(oSheet, cText, cAddr)
                        
                        ' this_xls_book, this_xls_sheet, this_xls_row, this_xls_col
                        cText = ReplaceStr(cText, "this_xls_book", "''" + oSheet.Parent.Name + "''")
                        cText = ReplaceStr(cText, "this_xls_sheet", "''" + oSheet.Name + "''")
                        cText = ReplaceStr(cText, "this_xls_row", VBA.Format(oSheet.Range(cAddr).Row, "0"))
                        cText = ReplaceStr(cText, "this_xls_col", VBA.Format(oSheet.Range(cAddr).Column, "0"))
                        
                        cSql = cSql & VBA.Chr(10) & "INSERT " & cTabName & " " & ReplaceStr(ReplaceStr(cText, "thischar", cReplaceText), "this", cReplace)
                        nIndex = nIndex + 1
                    End If
                End If
                
                If nIndex >= 300 Or VBA.LEN(cSql) > 5000 Then
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="execute A_EXEC '" + cSql + "'")
                    oConnection.Execute "execute A_EXEC '" + cSql + "'"
                    nIndex = 0
                    cSql = ""
                End If
            Next nCnt
            
            If cSql <> "" Then
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="execute A_EXEC '" + cSql + "'")
                oConnection.Execute "execute A_EXEC '" + cSql + "'"
            End If
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cInfo:="Успешно!")
            
            cSql = ScriptGet(oSheet, "control_proc")
            If cSql <> "" Then
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Контроль бюджетной классификации и сумм")
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:=cSql)
                
                Set oRecordSet = CreateObject("ADODB.RecordSet")
                oRecordSet.Open cSql, oConnection, 2, 1, 1
                
                bErrCtl = False
                If Not oRecordSet Is Nothing Then
                    If oRecordSet.State = 1 Then
                        oRecordSet.MoveFirst
                        While Not oRecordSet.EOF
                            If oRecordSet.Fields("err_mess").Value <> "" Then
                                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, _
                                    cInfo:="Строка: " & oRecordSet.Fields("xls_row").Value & ", графа: " & oRecordSet.Fields("xls_col").Value)
                                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=4, cInfo:="Описание: " & oRecordSet.Fields("err_mess").Value)
                                bErrCtl = True
                            End If
                            oRecordSet.MoveNext
                        Wend
                    End If
                End If
                
                If Not oRecordSet Is Nothing Then
                    If oRecordSet.State = 1 Then oRecordSet.Close
                End If
                Set oRecordSet = Nothing
                
                If bErrCtl Then
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                        , cInfo:="Ошибка! Не проходит контроль бюджетной классификации и сумм!")
                    GoTo SkipSheet
                Else
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cInfo:="Успешно!")
                End If
            End If
            
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="Контроль данных Центром Контроля и сохранение данных на сервере")
            cSql = ScriptGet(oSheet, "save_proc")
            If cSql <> "" Then
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:=cSql)
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="Результаты процедур Центра Контроля и сохранения данных")
                
                Set oRecordSet = CreateObject("ADODB.RecordSet")
                oRecordSet.Open cSql, oConnection, 2, 3, 1
                
                cFullHtml = ""   ' полный html
                cHtml = ""       ' текущий html с таблицами
                cHeader = ""     ' "шапка" текущего блока html
                cFooter = ""     ' "хвост" текущего блока html
                cParameters = "" ' перечень дополнительных параметров для подготовки протокола
                
                bRecordSetNext = False
                nResult = 0
                nHeaderResult = 0
                bExistsXMLColumn = False
                
                While Not oRecordSet Is Nothing
                    If oRecordSet.State = 1 Then
                        
                        bXMLHeader = False
                        bXMLColumn = False
                        For nFields = 1 To oRecordSet.Fields.Count
                            If VBA.UCase(oRecordSet.Fields(nFields - 1).Name) = VBA.UCase("XMLHeader") Then
                                bXMLHeader = True
                            End If
                            
                            If VBA.UCase(oRecordSet.Fields(nFields - 1).Name) = VBA.UCase("XMLColumn") Then
                                bXMLColumn = True
                            End If
                        Next
                        
                        ' курсор с заголовком протокола
                        If bXMLHeader And oRecordSet.RecordCount > 0 Then
                            ' если в переменных cHeader, cFooter или cHtml что то есть - добавляем их в протокол
                            ' но не добавляем в протокол, если есть только шапка протокола с cRepResult=1 и нет табличных данных
                            ' по аналогии с веб для протокола из ХП dbo.SAVE
                            If (cHeader <> "" Or cFooter <> "" Or cHtml <> "") And (nHeaderResult <> 1 Or bExistsXMLColumn) Then
                                cFullHtml = cFullHtml + cHeader + "<br>" + cHtml + cFooter
                                cHtml = ""
                            End If
                            
                            cHeader = ""
                            cFooter = ""
                            nHeaderResult = 0
                            cParameters = ""
                            
                            oRecordSet.MoveFirst
                            While Not oRecordSet.EOF
                                If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cRepHeader") Then
                                    cHeader = VBA.Trim(oRecordSet.Fields("value").Value)
                                End If
                                
                                If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cRepFooter") Then
                                    cFooter = VBA.Trim(oRecordSet.Fields("value").Value)
                                End If
                                
                                If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cRepResult") Then
                                    nHeaderResult = VBA.Val(oRecordSet.Fields("value").Value)
                                    nResult = VBA.IIf(nResult > nHeaderResult, nResult, nHeaderResult)
                                End If
                                
                                If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cParameters") Then
                                    cParameters = VBA.Trim(oRecordSet.Fields("value").Value)
                                End If
                                
                                oRecordSet.MoveNext
                            Wend
                        End If
                        
                        ' курсор с описанием данных
                        ' данные выводим только когда cRepResult заголовка протокола>1 (принудитеьлный вывод без табличных данных)
                        ' или когда cRepResult для заголовка вообще не было
                        
                        bExistsXMLColumn = (bXMLColumn And oRecordSet.RecordCount > 0)
                        If bExistsXMLColumn Then
                            oRecordSet.MoveFirst
                            While Not oRecordSet.EOF
                                If VBA.Trim(cHeader) = "" Then
                                    If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cRepHeader") Then
                                        cHeader = VBA.Trim(oRecordSet.Fields("value").Value)
                                    End If
                                End If
                                
                                If VBA.Trim(cFooter) = "" Then
                                    If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cRepFooter") Then
                                        cFooter = VBA.Trim(oRecordSet.Fields("value").Value)
                                    End If
                                End If
                                
                                If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cRepResult") Then
                                    nResult = VBA.IIf(nResult > VBA.Val(oRecordSet.Fields("value").Value) _
                                        , nResult _
                                        , VBA.Val(oRecordSet.Fields("value").Value))
                                End If
                                
                                If VBA.Trim(VBA.UCase(oRecordSet.Fields("code").Value)) = VBA.UCase("cDataDesc") Then
                                    bRecordSetNext = True
                                End If
                                
                                oRecordSet.MoveNext
                            Wend
                            
                            If bRecordSetNext Then
                                Set oRecordSetDesc = oRecordSet.Clone()
                                Set oRecordSet = oRecordSet.NextRecordset
                                If Not oRecordSetDesc Is Nothing And Not oRecordSet Is Nothing Then
                                    If oRecordSetDesc.State = 1 And oRecordSet.State = 1 Then
                                        cHtmlAdd = ""
                                        
                                        If oRecordSetDesc.RecordCount > 0 And oRecordSet.RecordCount > 0 Then
                                            cGrpFld = ""
                                            cGrpDesc = ""
                                            
                                            oRecordSetDesc.MoveFirst
                                            While Not oRecordSetDesc.EOF
                                                If VBA.Trim(VBA.UCase(oRecordSetDesc.Fields("code").Value)) = VBA.Trim(VBA.UCase("cGroupFields")) Then
                                                    cGrpFld = VBA.Trim(oRecordSetDesc.Fields("value").Value)
                                                End If

                                                If VBA.Trim(VBA.UCase(oRecordSetDesc.Fields("code").Value)) = VBA.Trim(VBA.UCase("cGroupDesc")) Then
                                                    cGrpDesc = VBA.Trim(oRecordSetDesc.Fields("value").Value)
                                                End If

                                                oRecordSetDesc.MoveNext
                                            Wend

                                            cDateFld = ""
                                            aGrpFld = VBA.Split(cGrpFld, "|")
                                            For nFldCnt = 0 To UBound(aGrpFld, 1)
                                                cTmp = aGrpFld(nFldCnt)
                                                If VBA.InStr(1, cGrpDesc, "@#DATE#" + cTmp) > 0 Then
                                                    cDateFld = cDateFld + "#" + cTmp + "#"
                                                End If
                                            Next nFldCnt
                                            cGrpDesc = VBA.Replace(cGrpDesc, "@#DATE#", "@")

                                            Set oXmlData = XmlCreateDomDocument()
                                            oRecordSet.MoveFirst
                                            Call oRecordSet.Save(oXmlData, 1)
                                            
                                            Set oNodeList = oXmlData.DocumentElement.SelectNodes("*")
                                            If oNodeList.Length > 0 Then
                                                For Each oNodeData In oNodeList
                                                    If oNodeData.nodeName Like "*:data" Or oNodeData.nodeName = "data" Then
                                                        For Each oNodeRow In oNodeData.SelectNodes("*")
                                                            If oNodeRow.nodeName Like "*:row" Or oNodeRow.nodeName = "row" Then
                                                                cTmpFld = "|" + VBA.Trim(cGrpFld) + "|"
                                                                cTmpDesc = cGrpDesc
                                                                
                                                                If VBA.Trim(cGrpFld) <> "" Then
                                                                    For nFldCnt = 0 To UBound(aGrpFld, 1)
                                                                        cTmp = aGrpFld(nFldCnt)
                                                                        cAttr = oNodeRow.getAttribute(cTmp)
                                                                        If VBA.InStr(1, cDateFld, "#" + cTmp + "#") > 0 Then
                                                                            If VBA.InStr(1, cAttr, "T") > 0 Then
                                                                                cAttr = VBA.Left(cAttr, VBA.InStr(1, cAttr, "T") - 1)
                                                                            End If
                                                                            
                                                                            cVal = VBA.IIf( _
                                                                                VBA.Trim(cAttr) <> "" _
                                                                                , VBA.Trim(VBA.Format(cAttr, "dd.mm.yyyy")) _
                                                                                , "б/д" _
                                                                            )
                                                                        Else
                                                                            cVal = VBA.Trim(cAttr)
                                                                        End If
                                                                        cTmpFld = VBA.Replace(cTmpFld, "|" + VBA.Trim(cTmp) + "|", "|" + VBA.Trim(cVal) + "|", 1, 99, 1)
                                                                        cTmpDesc = VBA.Replace(cTmpDesc, "@" + VBA.Trim(cTmp), cVal, 1, 99, 1)
                                                                    Next nFldCnt
                                                                End If
                                                                
                                                                cTmpFld = VBA.Trim(VBA.Replace(cTmpFld, "|", " "))
                                                                Call oNodeRow.setAttribute("cgroupfields", cTmpFld)
                                                                Call oNodeRow.setAttribute("cgroupdesc", cTmpDesc)
                                                            End If
                                                        Next oNodeRow
                                                    End If
                                                Next oNodeData
                                            End If
                                            
                                            ' описания cXmlDesc
                                            cXmlDesc = XmlCreateFromRecordSet(oRecordSetDesc)
                                            cXmlDesc = XmlGetRowOnly(cXmlDesc)
                                            cXmlDesc = "<?xml version = ""1.0"" encoding=""Windows-1251"" standalone=""yes""?>" _
                                                + VBA.vbNewLine + "<VFPData>" _
                                                + VBA.vbNewLine + cXmlDesc _
                                                + VBA.vbNewLine + "</VFPData>" _
                                                + VBA.vbNewLine

                                            ' вспомогательное преобразование описаний cXmlDesc
                                            cXsltDesc = ScriptGet(oSheet, "XMLReportDescXslt")
                                            cXmlDesc = XmlTransform(cXmlDesc, cXsltDesc)
                                            
                                            ' данные cXmlData
                                            cXmlData = oXmlData.XML
                                            
                                            ' убираем лишние тэги
                                            cXmlDesc = VBA.Right(cXmlDesc, VBA.LEN(cXmlDesc) - VBA.InStr(1, cXmlDesc, ">"))
                                            cXmlData = XmlGetRowOnly(cXmlData)

                                            ' формируем общий xml
                                            cXmlFull = "<?xml version = ""1.0"" encoding=""Windows-1251""?>" _
                                                + VBA.vbNewLine + "<root>" _
                                                + VBA.vbNewLine + cXmlDesc _
                                                + VBA.vbNewLine + "<data>" _
                                                + VBA.vbNewLine + cXmlData _
                                                + VBA.vbNewLine + "</data>" _
                                                + VBA.vbNewLine + "</root>" _
                                                + VBA.vbNewLine
                                            
                                            ' основное преобразование
                                            cXsltFull = ScriptGet(oSheet, "XMLReportXslt")
                                            cHtmlAdd = XmlTransform(cXmlFull, cXsltFull)
                                        End If
                                        
                                        cHtml = cHtml + cHtmlAdd
                                    End If
                                End If
                                
                                bRecordSetNext = False
                                If Not oRecordSetDesc Is Nothing Then
                                    If oRecordSetDesc.State = 1 Then oRecordSetDesc.Close
                                End If
                                Set oRecordSetDesc = Nothing
                            End If
                        End If
                    End If
                    
                    Set oRecordSet = oRecordSet.NextRecordset
                Wend
                
                If (cHeader <> "" Or cFooter <> "" Or cHtml <> "") And (nHeaderResult <> 1 Or bExistsXMLColumn) Then
                    cFullHtml = cFullHtml + cHeader + "<br>" + cHtml + cFooter
                End If
                
                If cFullHtml <> "" Then
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=4, cInfo:=cFullHtml)
                    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, cInfo:="<TABLE STYLE=""FONT-SIZE: X-SMALL""><TR><TD>")
                    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cInfo:="")
                    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, cInfo:="</TD><TD><TABLE STYLE=""FONT-SIZE: X-SMALL""><TR><TD>")
                    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, cInfo:=VBA.Replace(cFullHtml, "<HR>", ""))
                    Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, cInfo:="</TD></TR></TABLE></TD></TR></TABLE>")
                End If
                
                If Not oRecordSet Is Nothing Then
                    If oRecordSet.State = 1 Then oRecordSet.Close
                End If
                Set oRecordSet = Nothing
                
                nErrorControl = VBA.IIf(nResult > nErrorControl, nResult, nErrorControl)
                If nResult > 2 Then
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                        , cInfo:="Ошибка! Не проходит контроль Центра Контроля, данные не сохранены!")
                    GoTo SkipSheet1
                Else
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cInfo:="Успешно!")
                End If
            Else
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                    , cInfo:="Ошибка! Отсутствует процедура сохранения данных!")
                GoTo SkipSheet
            End If
            
            cProperty = ScriptGet(oSheet, "del_file")
            If cProperty <> "" Then
                Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=2, cInfo:="Дополнительные действия после сохранения")
                If VBA.Dir(cProperty) <> "" Then
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="Удаление файла: " + cProperty)
                    Call VBA.Kill(cProperty)
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="Успешно!")
                Else
                    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, nMode:=1, nLevel:=3, cInfo:="Успешно!")
                End If
            End If
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cInfo:="Данные страницы: " + oSheet.Name + " успешно сохранены на сервер!")
        Else
            Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=3, cHtmSpanStyle:="color: red; font-weight: bold;" _
                , cInfo:="Ошибка! Страница: " + oSheet.Name + " не содержит конструкции сохранения!")
            GoTo SkipSheet
        End If
NextSheet:
    Next oSheet

    nErrorSave = VBA.IIf(nErrorControl > nErrorSave, nErrorControl, nErrorSave)
    
    If nModeSave = 0 Then
        Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cInfo:="Системный протокол приема")
        Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, nLevel:=2, cInfo:="<a href=""file://" + VBA.Replace(cLogSql, "\", "/") + """>" + cLogSql + "</a>")
        Call PutInfo(cFileHtm:=cLogCtl, nMode:=1, cInfo:=cLogCtlEnd)
    End If
    Call ServerConnectClose
    
    Application.StatusBar = False
    oBook.Saved = True
    Application.ThisWorkbook.Saved = True
    
    Call ChangeToolbar(2)
    If nModeSave = 0 Then
        nVal = VBA.MsgBox( _
            VBA.IIf(nErrorSave = 1, "Данные документа успешно сохранены на сервере!", _
            VBA.IIf(nErrorSave = 2, "Имеются не пройденные информационные контроли, данные сохранены на сервере!", _
            VBA.IIf(nErrorSave = 3, "Имеются не пройденные блокирующие контроли, сохранение таких данных невозможно!", _
            VBA.IIf(nErrorSave = 4, "В процессе приема обнаружены ошибки, сохранение данных невозможно!", _
            "Неизвестная ошибка, сохранение данных невозможно!")))) + VBA.vbNewLine _
            + VBA.vbNewLine + "Протокол приема смотрите в файле:" _
            + VBA.vbNewLine + cLogCtl _
            + VBA.vbNewLine + "Открыть файл для просмотра?" _
            , VBA.vbYesNo + VBA.vbInformation, "Внимание")
        If nVal = 6 Then
            cCmd = "iexplore.exe " + cLogCtl
            RetVal = WshShell.Run(cCmd, 1, False)
        End If
    End If
    
    Exit Sub

ErrSheet:
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cHtmSpanStyle:="color: red; font-weight: bold;" _
        , cInfo:="Ошибка! Номер: " + VBA.str(Err.Number) + ", источник: " + Err.Source + ", описание: " + Err.Description)
SkipSheet:
    nErrorSave = 4
SkipSheet1:
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cInfo:="Данные страницы: " + oSheet.Name + " не сохранены на сервер!")
    GoTo NextSheet

ErrMain:
    Call ServerConnectClose
    Application.StatusBar = False

    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cHtmSpanStyle:="color: red; font-weight: bold;" _
        , cInfo:="Ошибка! Номер: " + VBA.str(Err.Number) + ", источник: " + Err.Source + ", описание: " + Err.Description)
    Call PutInfo(nModeTxt:=nModeSave, cFileTxt:=cLogSql, cFileHtm:=cLogCtl, nMode:=1, nLevel:=1, cInfo:="Данные книги MS Excel: " + oBook.Name + " не сохранены на сервер!")
    
    If nModeSave = 0 Then
        nVal = VBA.MsgBox("В процессе приема обнаружены системные ошибки!" + VBA.vbNewLine _
                    + VBA.vbNewLine + "Системный протокол приема смотрите в файле:" _
                    + VBA.vbNewLine + cLogSql _
                    + VBA.vbNewLine + "Открыть файл для просмотра?" _
                    , VBA.vbYesNo + VBA.vbInformation, "Внимание")
        If nVal = 6 Then
            cCmd = "notepad.exe " + GetShortPath(cLogSql)
            RetVal = WshShell.Run(cCmd, 1, False)
        End If
    End If
    
    nErrorSave = 4
End Sub

Sub ServerConnectClose()
    If Not VBA.IsEmpty(oConnection) Then
        If Not oConnection Is Nothing Then
            oConnection.Close
        End If
    End If
    Set oConnection = Nothing
End Sub

Function ServerConnectOpen(ByVal oBook As Workbook, ByRef cRetSrv As String, ByRef cRetDb As String, ByRef cRetUser As String) As String
    Dim cSrv As String, cDb As String, cUser As String, cCorr As String, oSheet As Worksheet, nCnt As Long _
        , aSrv() As String, aDb() As String, aUser() As String, aCorr() As String, aIsNtUser() As Long, nIndex As Long _
        , bFound As Boolean, cPrompt As String, nIsNtUser As Long
    
    On Error GoTo ErrMsg
    
    nCnt = 0
    For Each oSheet In oBook.Sheets
        If oSheet.Scripts.Count > 0 And oSheet.Visible = -1 Then
            cSrv = ScriptGet(oSheet, "srv_name")
            cDb = ScriptGet(oSheet, "db_name")
            cUser = ScriptGet(oSheet, "dbuser_name")
            cCorr = ScriptGet(oSheet, "corr_out")
            nIsNtUser = VBA.Val(ScriptGet(oSheet, "dbuser_isnt"))
            
            If cSrv <> "" And cDb <> "" And cUser <> "" Then
                If nCnt = 0 Then
                    ReDim Preserve aSrv(nCnt), aDb(nCnt), aUser(nCnt), aCorr(nCnt), aIsNtUser(nCnt)
                    aSrv(nCnt) = cSrv
                    aDb(nCnt) = cDb
                    aUser(nCnt) = cUser
                    aCorr(nCnt) = cCorr
                    aIsNtUser(nCnt) = nIsNtUser
                    nCnt = nCnt + 1
                Else
                    bFound = False
                    For nIndex = 0 To nCnt - 1
                        If cSrv = aSrv(nIndex) And cDb = aDb(nIndex) And cUser = aUser(nIndex) And cCorr = aCorr(nIndex) Then
                            bFound = True
                        End If
                    Next nIndex
                    
                    If Not bFound Then
                        ReDim Preserve aSrv(nCnt), aDb(nCnt), aUser(nCnt), aCorr(nCnt), aIsNtUser(nCnt)
                        aSrv(nCnt) = cSrv
                        aDb(nCnt) = cDb
                        aUser(nCnt) = cUser
                        aCorr(nCnt) = cCorr
                        aIsNtUser(nCnt) = nIsNtUser
                        nCnt = nCnt + 1
                    End If
                End If
            End If
        End If
    Next oSheet
    
    If nCnt = 0 Then
        ServerConnectOpen = "Книга [" + oBook.Name + "] не содержит информации о базе и сервере!"
        Exit Function
    End If
    
    If nCnt > 1 Then
        cPrompt = ""
        For nIndex = 0 To nCnt - 1
            cPrompt = cPrompt + VBA.Trim(VBA.str(nIndex + 1)) + " - Сервер: [" + aSrv(nIndex) + "], база: [" + aDb(nIndex) + "], пользователь: [" + aUser(nIndex) + "]." + VBA.vbNewLine
        Next nIndex
        
        cPrompt = cPrompt + "0 - Выход."
        cPrompt = VBA.InputBox(cPrompt, "Выберите вариант подключения")
        nIndex = VBA.Val(cPrompt)
        
        If 1 <= nIndex And nIndex <= nCnt Then
            cSrv = aSrv(nIndex - 1)
            cDb = aDb(nIndex - 1)
            cUser = aUser(nIndex - 1)
            cCorr = aCorr(nIndex - 1)
            nIsNtUser = aIsNtUser(nIndex - 1)
        Else
            ServerConnectOpen = "Пользователь не выбрал вариант подключения!"
            Exit Function
        End If
    Else
        cSrv = aSrv(0)
        cDb = aDb(0)
        cUser = aUser(0)
        cCorr = aCorr(0)
        nIsNtUser = aIsNtUser(0)
    End If
    cRetSrv = cSrv
    cRetDb = cDb
    cRetUser = cUser
    
    Set oConnection = CreateObject("ADODB.Connection")
    If nIsNtUser = 1 Then
        oConnection.ConnectionString = "Provider=SQLOLEDB;Server=" + cSrv + ";Database=" + cDb + ";Trusted_Connection=yes;"
    Else
        oConnection.ConnectionString = "Provider=SQLOLEDB;Server=" + cSrv + ";Database=" + cDb + ";Uid=" + cUser + ";Pwd=" + GetCode(cCorr)
    End If
    oConnection.ConnectionTimeout = 0
    oConnection.CommandTimeout = 0
    oConnection.CursorLocation = 3
    oConnection.Mode = 3
    oConnection.Open
    
    oConnection.Execute "SET LANGUAGE ENGLISH"
    oConnection.Execute "SET TRANSACTION ISOLATION LEVEL READ UNCOMMITTED"
    oConnection.Execute "SET QUOTED_IDENTIFIER ON"
    oConnection.Execute "SET ANSI_NULLS ON"
    oConnection.Execute "SET ARITHABORT ON"
    oConnection.Execute "SET CONCAT_NULL_YIELDS_NULL ON"
    oConnection.Execute "SET ANSI_PADDING ON"
    oConnection.Execute "SET ANSI_WARNINGS ON"
    oConnection.Execute "SET NUMERIC_ROUNDABORT OFF"
    oConnection.Execute "SET NOCOUNT ON"
    oConnection.Execute "SET XACT_ABORT ON"
    
    ServerConnectOpen = ""
    Exit Function
    
ErrMsg:
    Call ServerConnectClose
    ServerConnectOpen = "Ошибка! Номер: " + VBA.str(Err.Number) + ", источник: " + Err.Source + ", описание: " + Err.Description
End Function

Function XmlCreateDomDocument(Optional ByRef cXmlVersion As String = "") As Variant
    Dim oXmlDom, cXmlObject As String
    
    Set oXmlDom = Nothing
    If cXmlVersion = "" Then
        cXmlVersion = "6.0"
    End If
    
    Select Case cXmlVersion
    Case "3.0"
        ' http://www.microsoft.com/downloads/details.aspx?familyid=28494391-052b-42ff-9674-f752bdca9582&displaylang=en
        cXmlObject = "MSXML2.DOMDocument.3.0"
    Case "4.0"
        ' http://www.microsoft.com/downloads/details.aspx?FamilyID=3144b72b-b4f2-46da-b4b6-c5d7485f2b42&DisplayLang=en
        cXmlObject = "MSXML2.DOMDocument.4.0"
    Case "6.0"
        ' http://www.microsoft.com/downloads/details.aspx?familyid=993C0BCF-3BCF-4009-BE21-27E85E1857B1&displaylang=en
        cXmlObject = "MSXML2.DOMDocument.6.0"
    Case Else
        cXmlObject = ""
        cXmlVersion = ""
    End Select
    
    If cXmlObject <> "" And oXmlDom Is Nothing Then
        On Error GoTo LError
        Set oXmlDom = CreateObject(cXmlObject)
        GoTo LExit
LError:
        Set oXmlDom = Nothing
        Select Case cXmlVersion
        Case "3.0"
            cXmlVersion = ""
        Case "4.0"
            cXmlVersion = "3.0"
        Case "6.0"
            cXmlVersion = "4.0"
        Case Else
            cXmlVersion = ""
        End Select
        
        If cXmlVersion <> "" Then
            Set oXmlDom = XmlCreateDomDocument(cXmlVersion)
        End If
LExit:
        On Error GoTo 0
    End If
    
    If cXmlVersion = "" Then
        Set oXmlDom = Nothing
    End If
    
    Set XmlCreateDomDocument = oXmlDom
End Function

Function XmlCreateFromRecordSet(ByVal oRecordSet As Variant, Optional ByVal cXslt As String = "") As String
    Dim cXmlResult As String, oXmlDom
    
    cXmlResult = ""
    Set oXmlDom = XmlCreateDomDocument()
    
    If Not oXmlDom Is Nothing Then
        ' преобразовываем курсор
        oRecordSet.MoveFirst
        Call oRecordSet.Save(oXmlDom, 1)
        
        cXmlResult = oXmlDom.XML
        ' cXmlResult = VBA.Replace(cXmlResult, "encoding=""UTF-8""", "encoding=""windows-1251""")
        
        ' если нужно, выполняем преобразование
        If VBA.Trim(cXslt) <> "" Then
            ' необходимо выполнить предварительное преобразование. Преобразовываем в переменную
            cXmlResult = XmlTransform(cXmlResult, cXslt)
            
            ' почему - то когда преобразовываем через переменную, а не через файл, то msxml вставляет всегда encoding utf-16
            ' cXmlResult = VBA.Replace(cXmlResult, "encoding=""UTF-16""", "encoding=""windows-1251""")
        End If
    End If
    
    Set oXmlDom = Nothing
    XmlCreateFromRecordSet = cXmlResult
End Function

Function XmlGetRowOnly(ByVal cXml As String) As String
    Dim cXmlResult As String, aXml() As String, cDelimiter As String, nCnt As Long, aTerm As Variant
    
    cXmlResult = VBA.Trim(cXml)
    If cXmlResult <> "" Then
        aTerm = Array("s", "dt", "rs", "z")
        For nCnt = 0 To UBound(aTerm, 1)
            cXmlResult = VBA.Replace(cXmlResult, "<" + aTerm(nCnt) + ":", "<")
            cXmlResult = VBA.Replace(cXmlResult, "</" + aTerm(nCnt) + ":", "</")
        Next nCnt
        
        cDelimiter = ""
        If cDelimiter = "" And VBA.InStr(1, cXmlResult, ":data>") > 0 Then
            cDelimiter = ":data>"
        End If
        If cDelimiter = "" And VBA.InStr(1, cXmlResult, "<data>") > 0 Then
            cDelimiter = "data>"
        End If
        
        If cDelimiter <> "" Then
            aXml = VBA.Split(cXmlResult, cDelimiter)
            If UBound(aXml, 1) = 2 Then
                cXmlResult = aXml(1)
                For nCnt = VBA.LEN(cXmlResult) To 1 Step -1
                    If VBA.Mid(cXmlResult, nCnt, 1) = "<" Then
                        cXmlResult = VBA.Left(cXmlResult, nCnt - 1)
                        Exit For
                    End If
                    
                    If VBA.Mid(cXmlResult, nCnt, 1) = ">" Then
                        Exit For
                    End If
                Next nCnt
            End If
        End If
    End If
    
    XmlGetRowOnly = cXmlResult
End Function

Function XmlTransform(ByVal cXml As String, Optional ByVal cXslt As String = "") As String
    Dim cXmlResult As String, oXmlDom, oXsltDom
    
    cXmlResult = ""
    Set oXmlDom = XmlCreateDomDocument()
    Set oXsltDom = XmlCreateDomDocument()
    
    If Not oXmlDom Is Nothing And Not oXsltDom Is Nothing Then
        ' загружаем XML - cXml
        Call oXmlDom.LoadXML(cXml)
        
        ' загружаем XSLT - cXslt
        Call oXsltDom.LoadXML(cXslt)
        
        cXmlResult = oXmlDom.TransformNode(oXsltDom)
    End If
    
    Set oXmlDom = Nothing
    Set oXsltDom = Nothing
    XmlTransform = cXmlResult
End Function
