Sub send_to_xml_Click()
 
Dim strConnectString$, strSQL$, strHeading$
 
Dim cnn As ADODB.Connection
 
Dim rs As Recordset
 
 
 
'листаем книгу
 
For i = 1 To ThisWorkbook.Sheets.Count
 
'    For Each f In Worksheets(i).Range(Module3.scan_diap)
 
    ''''''''''''''''''''''''''и превращаем данные в record set
 
      NameDir = ThisWorkbook.Path & ""
 
      strConnectString = "Provider=MSDASQL.1;Persist Security Info=True;" & _
 
            "Data Source = Файлы Excel;Initial Catalog=" & NameDir
 
    
 
      'strConnectString = "Provider=Microsoft.Jet.OLEDB.3.51;" & _
 
        "Persist Security Info=False;" & _
 
         "Data Source=C:vb-dbxmltest.mdb"
 
         'scan_diap
 
      strSQL = "SELECT * FROM [" & Worksheets(i).Name & "$" & Module3.scan_diap & _
 
      "] IN '" & ThisWorkbook.FullName & "' [Excel 5.0;HDR=NO;IMEX=2];"
 
 
 
      strHeading$ = "preds"
 
      Set cnn = New ADODB.Connection
 
      Set rs = New ADODB.Recordset
 
      cnn.Open strConnectString$   ' устанавливаем связь
 
      Set rs = cnn.Execute(strSQL) ' создаем Recordset
 
      Call ExportXML(rs, strHeading$, strCode, "d:file1.xml") 'грузим в xml
 
'    Next f
 
Next i
 
 
 
End Sub
 
Public Sub ExportXML(rs As Recordset, strHeading$, strCode, FileName$) '
 
   
 
   ' Экспорт таблицы RecordSet в XML файл
 
   Dim xmlDoc As DOMDocument
 
   
 
   ' Cоздаем XMLDOM-объект
 
   Set xmlDoc = RecordsetToXMLDOM(rs, strHeading$, strCode) '
 
   ' выводим его в виде отдельного файла
 
   xmlDoc.Save FileName$
 
End Sub
 
Public Function RecordsetToXMLDOM(rs As Recordset, strHeading$, strCode) As DOMDocument '
 
   '
 
   ' Преобразование Recordset в DOMDocument
 
   '
 
   Dim fldField As Field
 
   Dim xmlDoc As DOMDocument
 
   Dim xmlFields As IXMLDOMElement
 
   Dim xmlField As IXMLDOMElement
 
   Dim i&
 
 
 
   ' создание экземпляра объекта
 
   Set xmlDoc = CreateObject("Microsoft.XMLDOM")    ' New DOMDocument
 
   ' записываем XML-константу объекта
 
   xmlDoc.loadXML "<?xml version=""1.0"" encoding=""windows-1251"" ?>" + _
 
    Replace("<" + strHeading + "/>", " ", "_")
 
'      Replace("<" + strHeading + "/>", " ", "_") 
 
 
 
   With rs
 
      ' Вывод содержимого полей таблицы
 
      .MoveFirst: i = 1
 
       Do Until .EOF
 
          
 
          ' создание нового узла
 
          Set xmlFields = xmlCode.documentElement.appendChild _
 
            (xmlDoc.createElement("OneRow" + LTrim(Str(i))))
 
 
 
          For Each fldField In rs.Fields   ' запись полей записи
 
               Set xmlField = xmlFields.appendChild( _
 
                xmlDoc.createElement(Replace(fldField.Name, " ", "_")))
 
                If IsNull(fldField.Value) = False Then
 
                    xmlField.Text = fldField.Value
 
                End If
 
          Next
 
         .MoveNext   ' к следующей записи набора
 
          i = i + 1
 
      Loop
 
   End With
 
   Set RecordsetToXMLDOM = xmlDoc   ' возвращаем созданный объект
 
End Function