Импорт/экспорт выбранных записей из/в файл

Private Sub cmdExportItms_Click()
    If vbYes = MsgBox("Экспортировать список заказа в файл обмена?" _
                    , vbQuestion + vbYesNo + vbDefaultButton1 _
                    , "Экспорт данных") Then
        Dim strFBody As String
        Dim strSQL As String
        
        ' выгружаем весь заказ в одну текстовую переменную (запрос: "rcvOrdItmAmountExport")
        strSQL = "SELECT tblPrice.PrcCode, tblOrderItems.OrdItmAmount FROM tblPrice INNER JOIN tblOrderItems ON tblPrice.PrcId = tblOrderItems.OrdItmItem WHERE (((tblOrderItems.OrdItmOrder)=" & txbOrdId.value & "));"
        strFBody = queryGetString(strSQL, Chr(13), , Chr(9))
        If strFBody <> "" Then
            Dim lngFn As Long           ' свободный номер в системе
            Dim strFName As String      ' имя файла-задания
            Dim strPath As String       ' расположение файла-задания
            ' формируем путь сохранения файла-задания
            strPath = CurrentProject.Path & "\.DataExchange\"
            ' проверяем: существует ли указанная директория. Если "нет", то создаём
            If Dir(strPath, vbDirectory) = "" Then MkDir strPath
            ' формируем имя сохраняемого файла-задания
            strFName = Format(Now(), "yyyy.mm.dd") _
                        & "_" & Replace(cboOrdWho.Column(1), " ", "_") _
                        & "_" & CStr(txbOrdId.value) & ".txt"
            ' сохраняем задание в файл
            lngFn = FreeFile    ' получаем свободный номер в системе
            Open strPath & strFName For Output As #lngFn
                Print #lngFn, strFBody  ' выводим заказ в файл
            Close #lngFn
            MsgBox "Завершён зкспорт списока заказа в файл обмена." _
                    , vbQuestion + vbYesNo + vbDefaultButton1 _
                    , "Экспорт данных"
        Else
            MsgBox "Нет данных для сохранения по выбранному заказу" _
                & " промежуточный Файл данных не будет создан." _
                , vbExclamation _
                , "Сохранение заказа."
        End If
    End If
End Sub

Public Function queryGetString( _
        ByRef strQuery As String, _
        ByRef strRowDelimeter As String, _
        Optional ByRef blnAddQuotes As Boolean = False, _
        Optional ByRef strColDelimeter As String, _
        Optional ByRef blnOnErrGoNext As Boolean = False _
        ) As Variant
    If blnOnErrGoNext Then On Error Resume Next
    Dim varOut As Variant
    '* early binding requires a reference to Microsoft ActiveX Data Objects Library *'
    'Dim rs As ADODB.Recordset
    'Set rs = New ADODB.Recordset '
    
    '* use late binding; no referenced needed *'
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    
    'Debug.Print strQuery
    rs.Open strQuery, CurrentProject.Connection
    If rs.BOF = False Or rs.EOF = False Then
        If strColDelimeter = "" Then strColDelimeter = Chr(9)
        If blnAddQuotes Then
            varOut = rs.GetString(2, , strColDelimeter, strRowDelimeter)   '2 = adClipString '
            '* strip off last quote *'
            If Len(varOut & vbNullString) > 0 Then
                varOut = Left(varOut, Len(varOut) - 2)
            End If
        Else
            varOut = rs.GetString(2, , strColDelimeter, strRowDelimeter)  '2 = adClipString '
        End If
    End If
    rs.Close
    Set rs = Nothing
    queryGetString = varOut
End Function

Private Sub ImportZakazF( _
        ByRef strFilePathName As String, _
        ByRef lngOrdId As Long _
        )   ' вносим полученные заказы из файла
    ' strFilePathName - адрес текстового файла, из которго будете импортировать
    ' lngOrdId - ИД заказа
    Dim dblPrcPrice As Double       ' цена позиции по прайсу
    Dim dbsCurrentDb As Database
    Dim lngAmmount As Long          ' количество
    Dim lngFn As Long               ' свободный номер файла в системе
    Dim lngPrcId As Long            ' код позиции в прайсе
    Dim strBookId As String         ' заказанная позиция
    Dim rsOrderItems As Recordset   ' список позиций в заказе
    Dim rsPrice As Recordset        ' прайс
    Dim strDoNotFined As String     ' список не найденных позиций
    Dim strFPN As String            ' ссылка на анализируемый файл-заказ
    Dim strFFCriteria As String     ' условия поиска записи в таблице
    Dim strSpliter As String        ' разделитель строки в файле-заказе
    Dim strVars() As String         ' массив переменных, полученный из строки файла-заказа
    Dim strZ As String              ' строка, полученноя из файла-заказа
    
    If strFilePathName = "" Then Exit Sub
    lngAmmount = CLng(0)
    strBookId = ""
    strDoNotFined = ""
    strFPN = strFilePathName
    Set dbsCurrentDb = CurrentDb
    With dbsCurrentDb
        ' получаем данные таблицы заказа
        Set rsOrderItems = .OpenRecordset("SELECT tblOrderItems.* FROM tblOrderItems;")
        ' получаем данные прайса
        Set rsPrice = .OpenRecordset("SELECT tblPrice.PrcId, tblPrice.PrcPrice, tblPrice.PrcCode FROM tblPrice;")
    End With
    lngFn = FreeFile
    Open strFPN For Input As #lngFn   ' открываем файл для чтения построчно
    While Not EOF(lngFn)                ' цикл "пока не найдено окончание файла"
        Line Input #lngFn, strZ         ' получили строку по порядку целиком для работы
        If strZ <> "" Then
            If InStr(1, strZ, Chr(9)) > 0 Then strSpliter = Chr(9) Else strSpliter = ";"
            strVars = Split(strZ, strSpliter)   ' получили из строки набор переменных
            strBookId = strVars(0)
            lngAmmount = CInt(strVars(1))
            With rsPrice
                .MoveFirst
                ' формируем критерий поиска записи в таблице
                strFFCriteria = "([PrcCode])=" & Chr(34) & strBookId & Chr(34)
                rsPrice.FindFirst (strFFCriteria)
                lngPrcId = !PrcId
                If Not IsNull(lngPrcId) Then dblPrcPrice = !PrcPrice
            End With
            If Not IsNull(lngPrcId) Then
                With rsOrderItems
                    .AddNew
                    !OrdItmOrder = lngOrdId
                    !OrdItmItem = lngPrcId
                    !OrdItmPrice = dblPrcPrice
                    !OrdItmAmount = lngAmmount
                    !OrdItmDateIn = Now()
                    !OrdItmDateChange = Now()
                    .Update
                End With
            Else
                strDoNotFined = strDoNotFined & strBookId & ", "
            End If
        End If
    Wend
    Close #lngFn
    Set rsOrderItems = Nothing
    Set rsPrice = Nothing
    If strDoNotFined <> "" Then
        MsgBox "Не найдены в базе и не внесены в заказ следующие позиции: " & strDoNotFined _
                , vbCritical _
                , "Импорт данных из файла"
    End If
End Sub