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
|