Форумы HiProg.com - MS ACCESS, VBA, VB

ник: Lukas
Без шапки, с небольшим форматированием:

Private rst As ADODB.Recordset Public Sub ReadFiles()     Dim f As Integer          With GetFiles()         If .Count = 0 Then             Exit Sub         Else             CreateRST             For f = 1 To .Count     '            Debug.Print .Item(f)                 ReadFile .Item(f)             Next f             CreateList             rst.Close             Set rst = Nothing         End If     End With End Sub Private Function GetFiles() As FileDialogSelectedItems     With Application.FileDialog(msoFileDialogFilePicker)         .AllowMultiSelect = True         .Filters.Clear         .Filters.Add "Текстовые файлы", "*.txt"         .Show         Set GetFiles = .SelectedItems     End With End Function Private Sub ReadFile(FullPath As String)     Const INSIDE_MARK As String = "1CClientBankExchange"     Const DELIMITER As String = "="          Dim TextLine, row     Dim i As Integer          Open FullPath For Input As #1         Line Input #1, TextLine         If TextLine = INSIDE_MARK Then 'Проверка на Внутренний признак файла обмена             Do While Not EOF(1)                 Line Input #1, TextLine                 If TextLine <> vbNullString Then                     row = Split(TextLine, DELIMITER)                     Select Case row(0)                         Case "ВерсияФормата", "Кодировка", "Отправитель", "Получатель", "ДатаСоздания", "ВремяСоздания", "ДатаНачала", _                             "ДатаКонца", "РасчСчет", "Документ", "СекцияРасчСчет", "ДатаНачала", "ДатаКонца", "РасчСчет", _                             "НачальныйОстаток", "ВсегоПоступило", "ВсегоСписано", "КонечныйОстаток", "КонецРасчСчет", "КонецДокумента"                         Case Is = "СекцияДокумент"                             rst.AddNew                             rst.Fields("СекцияДокумент") = row(1)                         Case Is = "КонецФайла"                             rst.UpdateBatch                             rst.MoveFirst                         Case Else                             rst.Fields(row(0)) = row(1)                     End Select                 End If             Loop         Else             MsgBox "Файл не содержит Внутренний признак файла обмена"         End If     Close #1 End Sub Private Sub CreateList()     Dim wsh As Worksheet     Dim i As Integer          With Workbooks.Add         Set wsh = .Worksheets(1)         With wsh             For i = 0 To rst.Fields.Count - 1                 .Cells(1, i + 1) = rst.Fields(i).Name                 Select Case rst.Fields(i).Type                     Case adDate                         .Columns(i + 1).NumberFormat = "dd/mm/yyyy"                     Case adCurrency                         .Columns(i + 1).Style = "Comma"                 End Select             Next i             .Cells(2, 1).CopyFromRecordset rst             .Cells.EntireColumn.AutoFit         End With     End With End Sub Private Sub CreateRST()     Dim i As Integer     Set rst = New ADODB.Recordset     With rst         With .Fields             .Append "СекцияДокумент", adVarChar, 255             .Append "Номер", adVarChar, 255             .Append "Дата", adDate, 8, adFldIsNullable             .Append "Сумма", adCurrency             .Append "КвитанцияДата", adDate, 8, adFldIsNullable             .Append "КвитанцияВремя", adDate, 8, adFldIsNullable             .Append "КвитанцияСодержание", adVarChar, 255             .Append "ПлательщикСчет", adVarChar, 20             .Append "ДатаСписано", adDate, 8, adFldIsNullable             .Append "Плательщик", adVarChar, 255             .Append "ПлательщикИНН", adVarChar, 12             .Append "Плательщик1", adVarChar, 255             .Append "Плательщик2", adVarChar, 255             .Append "Плательщик3", adVarChar, 255             .Append "Плательщик4", adVarChar, 255             .Append "ПлательщикРасчСчет", adVarChar, 20             .Append "ПлательщикБанк1", adVarChar, 255             .Append "ПлательщикБанк2", adVarChar, 255             .Append "ПлательщикБИК", adVarChar, 9             .Append "ПлательщикКорсчет", adVarChar, 20             .Append "ПолучательСчет", adVarChar, 20             .Append "ДатаПоступило", adDate, 8, adFldIsNullable             .Append "Получатель", adVarChar, 255             .Append "ПолучательИНН", adVarChar, 12             .Append "Получатель1", adVarChar, 255             .Append "Получатель2", adVarChar, 255             .Append "Получатель3", adVarChar, 255             .Append "Получатель4", adVarChar, 255             .Append "ПолучательРасчСчет", adVarChar, 20             .Append "ПолучательБанк1", adVarChar, 255             .Append "ПолучательБанк2", adVarChar, 255             .Append "ПолучательБИК", adVarChar, 9             .Append "ПолучательКорсчет", adVarChar, 20             .Append "ВидПлатежа", adVarChar, 255             .Append "ВидОплаты", adVarChar, 2             .Append "Код", adVarChar, 25             .Append "НазначениеПлатежа", adVarChar, 255             .Append "НазначениеПлатежа1", adVarChar, 255             .Append "НазначениеПлатежа2", adVarChar, 255             .Append "НазначениеПлатежа3", adVarChar, 255             .Append "НазначениеПлатежа4", adVarChar, 255             .Append "НазначениеПлатежа5", adVarChar, 255             .Append "НазначениеПлатежа6", adVarChar, 255             .Append "СтатусСоставителя", adVarChar, 2             .Append "ПлательщикКПП", adVarChar, 9             .Append "ПолучательКПП", adVarChar, 9             .Append "ПоказательКБК", adVarChar, 20             .Append "ОКАТО", adVarChar, 11             .Append "ПоказательОснования", adVarChar, 2             .Append "ПоказательПериода", adVarChar, 10             .Append "ПоказательНомера", adVarChar, 255             .Append "ПоказательДаты", adDate, 8, adFldIsNullable             .Append "ПоказательТипа", adVarChar, 2             .Append "Очередность", adVarChar, 2             .Append "СрокАкцепта", adInteger, 4             .Append "ВидАккредитива", adVarChar, 255             .Append "СрокПлатежа", adDate, 8, adFldIsNullable             .Append "УсловиеОплаты1", adVarChar, 255             .Append "УсловиеОплаты2", adVarChar, 255             .Append "УсловиеОплаты3", adVarChar, 255             .Append "ПлатежПоПредст", adVarChar, 255             .Append "ДополнУсловия", adVarChar, 255             .Append "НомерСчетаПоставщика", adVarChar, 255             .Append "ДатаОтсылкиДок", adDate, 8, adFldIsNullable         End With         .Open     End With End Sub