Attribute VB_Name = "SVOD_TO_FILE_R"
Option Explicit

Sub SVOD_TO_FILE()
myError
Dim SheetsService As Object
Dim lcFileName As String, lcPath As String, lcShablon As String, _
    lcKodReg As String, lcNumCor  As String, lnRes As Long
Dim SqlStr, wrkResultSet

        Set SheetsService = Sheets("Service")
        lcPath = SheetsService.Range("A54")

        If pnwrkConnect Is Nothing Then
            Call Server_Connect
        End If
        SqlStr = "select a.value as vvv " + _
                "from s_corr_app a,s_corr c " + _
                "where  a.object=(      select link " + _
                "       from s_objects " + _
                "       where code='COLUMN_DICT_OFK_CODE') " + _
                "       and a.link_up=c.link and c.link=" + "'" + SheetsService.Range("A16").Text + "'"

        ' выполнени
        Set wrkResultSet = pnwrkConnect.OpenRecordset(SqlStr, dbOpenDynaset)
        ' получим LINK  объекта
        If wrkResultSet.RecordCount > 0 Then ' корреспондент есть
                ' заполнение таблицы с данными
                'Sheets("SEEK_POP_SQLDATA").Range("A2").CopyFromRecordset wrkResultSet
                lcKodReg = wrkResultSet.Fields("vvv") 'Sheets("SEEK_POP_SQLDATA").Range("A2").Value
'               SheetsService.Range("A16") = Sheets("SEEK_POP_SQLDATA").Cells(2, 1).value
        Else
                MsgBox ("Корреспондент не имеет кода ОФК ")
                GoTo errror
        End If
        Set wrkResultSet = Nothing
'       lcKodReg = "063"
        If vba.Len(lcKodReg) = 1 Then
            lcKodReg = "0" + lcKodReg
        End If
        lcShablon = "MS" & lcKodReg & "_"
        lcNumCor = "00"
MetFile:
lcFileName = lcPath & lcShablon & lcNumCor & ".txt"
' Проверим а есть ли файл
If Dir(lcFileName) <> "" Then
    lnRes = MsgBox("Файл " & lcShablon & lcNumCor & ".txt " & "уже существует, перезаписать его ?", vbQuestion + vbYesNoCancel, pcNameApp & "Внимание")
    Select Case lnRes
        Case vbYes
                Call WRITE_TO_FILE(lcFileName)
        Case vbNo
                lcNumCor = InputBox("Введите номер коррекции", pcNameApp & "Внимание", lcNumCor)
                If lcNumCor = "" Then Exit Sub
                GoTo MetFile:
        Case vbCancel
    End Select
Else
    Call WRITE_TO_FILE(lcFileName)
errror:
End If
End Sub
Sub WRITE_TO_FILE(ByVal lcFileName As String)
Dim SheetsService As Object, SheetsReport As Object
Dim lcMonth As String, lcYear As String, lcCodeReg As String, lcCodeDoc As String, _
    lnOutEmptyBars  As Integer, lcLineValue As String, lcCodeStr As String, _
    nCnt As Long, nCntCol As Long, lcValue As String, lnSumma As Double

Application.StatusBar = "Подождите ... Идет запись в файл"

Set SheetsService = Sheets("Service")
Set SheetsReport = Sheets(Sheets("Service").Range("B19").Text)
With SheetsService
    lcCodeDoc = .Range("C10")
    lcCodeReg = .Range("C11")
    lcYear = .Range("C12")
    lcMonth = .Range("C13")
    lnOutEmptyBars = .Range("C14")
End With
Open lcFileName For Output As #1
' Формирование шапки
Print #1, lcCodeDoc
Print #1, lcCodeReg
Print #1, lcYear
Print #1, lcMonth
Print #1, ""
' Формирование информативной части
For nCnt = pnAddress_Row To pnAddress_Row + 1 + SheetsService.Range("A9")
    If SheetsReport.Cells(nCnt, 1) <> 0 Then
        lcCodeStr = ""
        lcCodeStr = SheetsReport.Cells(nCnt, pnAddress_Col - 1)
        If vba.Len(VBA.Trim(lcCodeStr)) > 2 Then
            lcCodeStr = VBA.Trim(lcCodeStr) & VBA.Space(6 - VBA.Len(VBA.Trim(lcCodeStr)))
        Else
            lcCodeStr = VBA.Space(6 - VBA.Len(VBA.Trim(lcCodeStr))) & VBA.Trim(lcCodeStr)
        End If
        lcCodeStr = lcCodeStr & "|"
        lnSumma = 0
        lcValue = ""
        For nCntCol = pnAddress_Col To pnAddress_Col + SheetsService.Range("A10") - 1
            lnSumma = lnSumma + SheetsReport.Cells(nCnt, nCntCol).Value
            lcValue = lcValue & VBA.Space(15 - VBA.Len(VBA.Str(SheetsReport.Cells(nCnt, nCntCol).Value))) & VBA.Str(SheetsReport.Cells(nCnt, nCntCol).Value) & "|"
        Next
        If lnOutEmptyBars = 1 Then
            Print #1, lcCodeStr & lcValue
        Else
            If lnSumma <> 0 Then
                Print #1, lcCodeStr & lcValue
            End If
        End If
    End If
Next
' Формирование заключительной части
Print #1, ""
Print #1, "#"
Print #1, SheetsReport.Range("WRITE_1")
Print #1, SheetsReport.Range("WRITE_2")
Print #1, SheetsReport.Range("WRITE_3")
Close #1
Application.StatusBar = False
End Sub


