module1.bas

xls_xml.rar

Attribute VB_Name = "Module1"
Option Explicit
Dim temp

Public SelectTableName As String
Public Conn As New ADODB.Connection
Public connString As String
Public rs As New ADODB.Recordset
Public index(2)
Function InitializeDataBase(FilePathName As String, filename As String) As String

    On Error GoTo errConn
    If Conn.State = 1 Then Quit
    'connString = "Driver={Microsoft Excel Driver (*.xls)};DriverId=790;DBQ=" & FilePathName
    connString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & FilePathName & ";Persist Security Info=False"
    Conn.ConnectionString = connString
    Conn.Open
    
    Exit Function
errConn:
    MsgBox Err.Description
    End
End Function

Function Quit() As String
    On Error Resume Next
    
    Conn.Close
    Set Conn = Nothing

End Function


Public Sub BindRs(filename)
   
'    If rs.State = 1 Then
'        rs.Close
'    End If
'    rs.Open "select * from [" & filename & "]", Conn, adOpenStatic, adLockOptimistic
'    If rs.RecordCount = 1 Then frmMain.Command1.Enabled = False
'    Set frmMain.DataGrid1.DataSource = rs
'
'
'    frmMain.DataGrid1.Refresh

End Sub

Public Sub Conversion(FilePathName, filename)
    Dim rs As New ADODB.Recordset
    Dim xmldoc As New MSXML.DOMDocument
    Dim rootElement As IXMLDOMElement
    Dim areaElement As IXMLDOMElement
    Dim areaidElement As IXMLDOMElement
    Dim itemElement As IXMLDOMElement
    Dim itemElement2 As IXMLDOMElement
    Dim node As IXMLDOMElement
    Dim count As Integer
    Dim rsString As String
    
    On Error GoTo Errs:
    
    Dim a As String
    a = Format(frmMain.DTPicker1.Value, "yyyyMM")
    a = "DATA000055" + a
    
    xmldoc.appendChild xmldoc.createProcessingInstruction("xml", " version=""1.0"" encoding=""GB2312""")
    Set rootElement = xmldoc.createElement(a)
    xmldoc.appendChild rootElement
    
    Set areaElement = xmldoc.createElement("area")
    rootElement.appendChild areaElement
    
    Set areaidElement = xmldoc.createElement("areaid")
    If frmMain.Option5.Value = True Then areaidElement.Text = "000055310000"
    If frmMain.Option6.Value = True Then areaidElement.Text = "000055000000"
    areaElement.appendChild areaidElement
   
    rsString = "select * from [" & SelectTableName & "]"
    
    rs.Open rsString, Conn


    'Set rs = cnn.Execute("select * from Sheet1")
    count = 0
    
    If Not rs.BOF And Not rs.EOF Then
        While Not rs.EOF
        
            Set itemElement = xmldoc.createElement("item")
            areaElement.appendChild itemElement
            
                Set itemElement2 = xmldoc.createElement("PK")
                itemElement2.Text = ""
                itemElement.appendChild itemElement2
                
                    Set node = xmldoc.createElement("key")
                    
                    node.Text = Trim(rs.Fields(0) & "")
                    itemElement2.appendChild node
                
                    Set node = xmldoc.createElement("intervaltype")
                    If frmMain.Option1.Value = True Then node.Text = "1"
                    If frmMain.Option2.Value = True Then node.Text = "2"
                    If frmMain.Option3.Value = True Then node.Text = "4"
                    
                    itemElement2.appendChild node
                    
                itemElement.appendChild itemElement2
            
            
                Set node = xmldoc.createElement("value")
                
                node.Text = Trim(rs.Fields(1) & "")
                
                itemElement.appendChild node
                
                Set node = xmldoc.createElement("remark")
                
                node.Text = Trim(rs.Fields(2) & "")
                itemElement.appendChild node
            
            areaElement.appendChild itemElement
            
            rs.MoveNext
            count = count + 1
        Wend
    End If
    
    If frmMain.Text2.Text <> "" Then
        filename = "保险统计指标-" + frmMain.Text2.Text + ".xml"
    Else
        filename = "保险统计指标-" + Mid(filename, 1, Len(filename) - 4) + ".xml"
    End If
    
    xmldoc.Save App.Path & "\" & filename
    rs.Close
    Set rs = Nothing
    
    temp = MsgBox("     文档转换完成了", , "保监会对接 XML 文档转换")
    
    Exit Sub
Errs:
    MsgBox Err.Description
End Sub