Пиво тоже хорошо кончается - струёй в унитаз - КАЙФ!!!!!!

Все хорошо, что хорошо кончается
Кроме пива

осталось в dbf и в mdb

Кстати как в dbf выгрузить таблицу MS Access
У кого нить есть функция???

и таков:

таков:

Результат таков:

Спасибо!!! ShadowOfSun за поддержку.


ФУУУУУххххххх 2 дня муружило

Оказалось всё вот так:
Выгрузка данных таблицы из MS Access без установленного на машине MS Excel.
Особая благодарность osmor_у

Public Function Fun_TABLE_IN_XLS(STR_TABLE_NAME As String, To_ROTIN As Boolean, TO_MESSING As Boolean) ' переброс таблицы в файл Excel ' To_Rotin = true - показать(открыть) файл ' To_Message = true - сообщить о перебросе If FUN_Vopros("Выгружаем в файл Excel? ", vbQuestion) = False Then Exit Function Dim FILE_STROKA As String ' Формируемая строка Dim DATA_STROKA As String ' Формируемая строка Dim lngPID As Variant ' просто переменная Dim FILE_NAME As String ' имя файла Dim FIEL As ADODB.Field ' поле Dim FIEL1 As ADODB.Field ' поле Dim rst2 As ADODB.Recordset ' набор записей Set rst2 = New ADODB.Recordset ' набор записей Dim ConnectionString As String ' Соединение Dim ExcelConnection As New ADODB.Connection ' Соединение Dim SQLCommand As String ' Формируемая строка команд Dim Cmd As New ADODB.Command ' команда GLB_Patch_REPORT = FUN_OUT_TABLE_String("TUNING_TBL", "Patch", "Папка_Отчетов", "ID") FILE_NAME = FUN_FILE_NAME_IN(STR_TABLE_NAME, "xls") FILE_NAME = FUN_Patch_File(GLB_Patch_REPORT, FILE_NAME) If FUN_FILE_YES_NO(FILE_NAME) = True Then FUN_Delete_File_Name (FILE_NAME) ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & FILE_NAME & ";Extended Properties=Excel 8.0" ExcelConnection.Open ConnectionString rst2.Open "SELECT " & STR_TABLE_NAME & ".* FROM " & STR_TABLE_NAME & " WITH OWNERACCESS OPTION;", GLB_con, adOpenKeyset, adLockOptimistic If rst2.EOF = False Then ' если таблица (rst2) не пуста перенос FILE_STROKA = "" '' названия столбцов (заголовки) For Each FIEL In rst2.Fields FILE_STROKA = FILE_STROKA & "[" & FIEL.Name & "] TEXT(150), " Next FIEL FILE_STROKA = Mid(FILE_STROKA, 1, Len(FILE_STROKA) - 2) SQLCommand = "CREATE TABLE sheet1 (" & FILE_STROKA & ")" Cmd.ActiveConnection = ExcelConnection Cmd.CommandText = SQLCommand Cmd.Execute DATA_STROKA = "" FILE_STROKA = "" If Not rst2.BOF Then rst2.MoveFirst 'SQLCommand = "INSERT INTO [Sheet1] (" & FIEL1.Name & ") VALUES ('" & FIEL1 & "')" 'INSERT INTO [Sheet1$] (F1, F2) values ('111', 'ABC') Do While Not rst2.EOF ' заполняем For Each FIEL1 In rst2.Fields 'значения If NZVB(FIEL1) <> "" Then DATA_STROKA = DATA_STROKA & "'" & FIEL1 & "', " Else DATA_STROKA = DATA_STROKA & "'-', " End If FILE_STROKA = FILE_STROKA & FIEL1.Name & ", " Next FIEL1 DATA_STROKA = Mid(DATA_STROKA, 1, Len(DATA_STROKA) - 2) FILE_STROKA = Mid(FILE_STROKA, 1, Len(FILE_STROKA) - 2) SQLCommand = "INSERT INTO [Sheet1] (" & FILE_STROKA & ") VALUES (" & DATA_STROKA & ")" 'MsgBox DATA_STROKA 'MsgBox FILE_STROKA Cmd.ActiveConnection = ExcelConnection Cmd.CommandText = SQLCommand Cmd.Execute DATA_STROKA = "" FILE_STROKA = "" rst2.MoveNext Loop End If rst2.Close Set rst2 = Nothing ExcelConnection.Close Set ExcelConnection = Nothing If TO_MESSING <> 0 Then Call MsgBox("Готово!!!", vbInformation) If To_ROTIN <> 0 Then lngPID = Shell(Mid(Get_Wind_Patch, 1, 3) & "Program Files\Internet Explorer\iexplore.exe " & FILE_NAME, 1) End Function

Глянь на рабочий вариант
Может чем поможет

Option Compare Database Public Function PrintFormByTemplate(TmplName As String, ID As Long) As Boolean 'Сформировать и вывести форму по шаблону TmplName по записи о работнике с идентификатором ID 'Шаблоны хранятся в папке Templates в каталоге клиента в формате XlS 'Возвращает Истину, если формирование успешно, Ложь - в противном случае     Dim XL As Object, XLBook As Object, XLSheet As Object     Dim ClientDir As String, TmplFile As String, OutputDir As String, OutputFile As String, Pos As Long     Dim Rst As Object, SubRst As Object, StrN As Long          'Выбрать запись о работнике     Set Rst = CurrentDb.OpenRecordset("SELECT * FROM [Работники] WHERE ID=" & ID)     If Rst.EOF Then         MsgBox "Запись о работнике отсутствует в базе.", , "Ошибка вывода формы " & TmplName         PrintFormByTemplate = False         Exit Function     End If          'Создать копию файла шаблона для заполнения     ClientDir = CurrentDb.Name     Pos = Len(ClientDir)     Do While Mid(ClientDir, Pos, 1) <> "\"         Pos = Pos - 1     Loop     ClientDir = Left(ClientDir, Pos)     TmplFile = ClientDir & "Templates\" + TmplName + ".xls"     If Dir(TmplFile) = "" Then         MsgBox "Не найден файл шаблона.", , "Ошибка вывода формы " & TmplName         PrintFormByTemplate = False         Exit Function     End If     If Dir("C:\Temp", vbDirectory) = "" Then         MkDir "C:\Temp"     End If     OutputDir = "C:\Temp\Персонал.Оперативная статотчетность"     If Dir(OutputDir, vbDirectory) = "" Then         MkDir OutputDir     End If     OutputFile = OutputDir & "\" & TmplName & " " & Rst![Фамилия] & " " & Rst![Имя] & " " & Rst![Отчество] & "  (таб. номер " & Rst![ТабНомер] & ").xls"     FileCopy TmplFile, OutputFile          'Создать объекты Excel On Error GoTo OLEError     Set XL = CreateObject("Excel.Application") On Error GoTo AnyError     Set XLBook = XL.Workbooks.Open(OutputFile)          'Вывод в конкретный шаблон     'Личная карточка работника (унифицированная форма Т-2)     If TmplName = "Т-2" Then                  '1-й лист         Set XLSheet = XLBook.Worksheets(1)         'награды         StrN = 8         Set SubRst = CurrentDb.OpenRecordset("SELECT * FROM [_Награды] WHERE [Работник]=" & ID & " ORDER BY ID")         Do While Not SubRst.EOF             XLSheet.Cells(StrN, 1) = SubRst![Наименование]             XLSheet.Cells(StrN, 33) = SubRst![ДокументНаим]             XLSheet.Cells(StrN, 48) = SubRst![ДокументНомер]             XLSheet.Cells(StrN, 56) = SubRst![ДокументДата]             SubRst.MoveNext             StrN = StrN + 1         Loop         'конец награды     End If     'Конец личная карточка работника (унифицированная форма Т-2)          XLBook.Save     XL.Visible = True     PrintFormByTemplate = True     Exit Function      OLEError:     MsgBox "Microsoft Excel - не установлен.", , "Ошибка вывода формы " & TmplName     PrintFormByTemplate = False     Exit Function AnyError:     MsgBox "Неопознанная ошибка.", , "Ошибка вывода формы " & TmplName     PrintFormByTemplate = False     Exit Function End Function

Но теперь другая проблемма
Каждая строчка всё ниже и ниже выводится

оказалось - вот так

SQLCommand = "INSERT INTO [Sheet1$] (" & FIEL1.Name & ") VALUES ('" & FIEL1 & "')"

Спасибо за перевод!!!
Кстати в чём причина? какую кодировку и куда засунуть надо?


А вопрос собственно во вставке данных

SQLCommand = "INSERT INTO sheet1." & FIEL1.Name & " VALUES (" & FIEL1 & ")"
не могу синтаксически правильно сформировать запрос
об этом и компилятор мне говорит (ВЫ НЕ ПРАВЫ!!!)

Типа перевел
А в чем вопрос собственно

Public Function Fun_TABLE_IN_XLS(STR_TABLE_NAME As String, To_ROTIN As Boolean, TO_MESSING As Boolean) ' переброс таблицы в файл Excel ' To_Rotin = true - показать(открыть) файл ' To_Message = true - сообщить о перебросе If FUN_Vopros("Выгружаем в файл Excel? ", vbQuestion) = False Then Exit Function Dim FILE_STROKA As String ' Формируемая строка Dim lngPID As Variant ' просто переменная Dim FILE_NAME As String ' имя файла Dim FIEL As ADODB.Field ' поле Dim FIEL1 As ADODB.Field ' поле Dim rst2 As ADODB.Recordset ' набор записей Set rst2 = New ADODB.Recordset ' набор записей Dim ConnectionString As String ' Соединение Dim ExcelConnection As New ADODB.Connection ' Соединение Dim SQLCommand As String ' Формируемая строка команд Dim Cmd As New ADODB.Command ' команда GLB_Patch_REPORT = FUN_OUT_TABLE_String("TUNING_TBL", "Patch", "Папка_Отчетов", "ID") FILE_NAME = FUN_FILE_NAME_IN(STR_TABLE_NAME, "xls") FILE_NAME = FUN_Patch_File(GLB_Patch_REPORT, FILE_NAME) If FUN_FILE_YES_NO(FILE_NAME) = True Then FUN_Delete_File_Name (FILE_NAME) ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=C:\Excelеtest.xls;Extended Properties=Excel 8.0" ExcelConnection.Open ConnectionString rst2.Open "SELECT " & STR_TABLE_NAME & ".* FROM " & STR_TABLE_NAME & " WITH OWNERACCESS OPTION;", GLB_con, adOpenKeyset, adLockOptimistic If rst2.EOF = False Then ' если таблица (rst2) не пуста перенос FILE_STROKA = "" ' названия столбцов (заголовки) For Each FIEL In rst2.Fields FILE_STROKA = FILE_STROKA & "[" & FIEL.Name & "] TEXT(150), " Next FIEL FILE_STROKA = Mid(FILE_STROKA, 1, Len(FILE_STROKA) - 2) SQLCommand = "CREATE TABLE sheet1 (" & FILE_STROKA & ")" Cmd.ActiveConnection = ExcelConnection Cmd.CommandText = SQLCommand Cmd.Execute For Each FIEL1 In rst2.Fields 'значения SQLCommand = "INSERT INTO sheet1." & FIEL1.Name & " VALUES (" & FIEL1 & ")" Cmd.ActiveConnection = ExcelConnection Cmd.CommandText = SQLCommand Cmd.Execute FILE_STROKA = "" Next FIEL1 End If rst2.Close Set rst2 = Nothing ExcelConnection.Close Set ExcelConnection = Nothing

Public Function Fun_TABLE_IN_XLS(STR_TABLE_NAME As String, To_ROTIN As Boolean, TO_MESSING As Boolean)
' ïåðåáðîñ òàáëèöû â ôàéë Excel
' To_Rotin = true - ïîêàçàòü(îòêðûòü) ôàéë
' To_Message = true - ñîîáùèòü î ïåðåáðîñå
If FUN_Vopros("Âûãðóæàåì â ôàéë Excel? ", vbQuestion) = False Then Exit Function
Dim FILE_STROKA As String ' Ôîðìèðóåìàÿ ñòðîêà
Dim lngPID As Variant ' ïðîñòî ïåðåìåííàÿ
Dim FILE_NAME As String ' èìÿ ôàéëà
Dim FIEL As ADODB.Field ' ïîëå
Dim FIEL1 As ADODB.Field ' ïîëå
Dim rst2 As ADODB.Recordset ' íàáîð çàïèñåé
Set rst2 = New ADODB.Recordset ' íàáîð çàïèñåé
Dim ConnectionString As String ' Ñîåäèíåíèå
Dim ExcelConnection As New ADODB.Connection ' Ñîåäèíåíèå
Dim SQLCommand As String ' Ôîðìèðóåìàÿ ñòðîêà êîìàíä
Dim Cmd As New ADODB.Command ' êîìàíäà

GLB_Patch_REPORT = FUN_OUT_TABLE_String("TUNING_TBL", "Patch", "Ïàïêà_Îò÷åòîâ", "ID")
FILE_NAME = FUN_FILE_NAME_IN(STR_TABLE_NAME, "xls")
FILE_NAME = FUN_Patch_File(GLB_Patch_REPORT, FILE_NAME)
If FUN_FILE_YES_NO(FILE_NAME) = True Then FUN_Delete_File_Name (FILE_NAME)


ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=C:\Excelåtest.xls;Extended Properties=Excel 8.0"
ExcelConnection.Open ConnectionString

rst2.Open "SELECT " & STR_TABLE_NAME & ".* FROM " & STR_TABLE_NAME & " WITH OWNERACCESS OPTION;", GLB_con, adOpenKeyset, adLockOptimistic
If rst2.EOF = False Then ' åñëè òàáëèöà (rst2) íå ïóñòà ïåðåíîñ

FILE_STROKA = ""
' íàçâàíèÿ ñòîëáöîâ (çàãîëîâêè)
For Each FIEL In rst2.Fields
FILE_STROKA = FILE_STROKA & "[" & FIEL.Name & "] TEXT(150), "
Next FIEL
FILE_STROKA = Mid(FILE_STROKA, 1, Len(FILE_STROKA) - 2)
SQLCommand = "CREATE TABLE sheet1 (" & FILE_STROKA & ")"
Cmd.ActiveConnection = ExcelConnection
Cmd.CommandText = SQLCommand
Cmd.Execute

For Each FIEL1 In rst2.Fields 'çíà÷åíèÿ

SQLCommand = "INSERT INTO sheet1." & FIEL1.Name & " VALUES (" & FIEL1 & ")"
Cmd.ActiveConnection = ExcelConnection
Cmd.CommandText = SQLCommand
Cmd.Execute
FILE_STROKA = ""
Next FIEL1
End If

rst2.Close
Set rst2 = Nothing
ExcelConnection.Close
Set ExcelConnection = Nothing