xmltable.vb

对现代企业来说

Imports System
Imports System.Data.Common
Imports System.Data
Imports System.IO
Imports System.Configuration
Imports System.Reflection


Public Class XMLTable
    Private _XMLPath As String
    Public ClassName As String
    Public ErrMsg As String
    Public CSVSeperator As String = ","
    Public Sub New(ByVal XMLPath As String)
        _XMLPath = XMLPath
        ClassName = Me.GetType.Name
    End Sub
    Public Function TableIndex() As String
        Dim str As String

        Return ClassName.Substring(4) & "_ID"
    End Function

    Public Function GetEmptyDS(ByRef Row As ValueType) As DataSet
        Dim ErrLoc As String = ClassName + ".GetDS"

        Try
            Dim ds As DataSet = New DataSet(ClassName)
            Dim dTable As New DataTable(ClassName)
            ds = DSAddCols(Row, dTable, ds)

            Return ds
        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
        End Try
    End Function
    Private Function DSAddCols(ByRef Row As ValueType, ByVal dTable As DataTable, ByVal dDataSet As DataSet) As DataSet
        Dim ErrLoc As String = ClassName + ".DSAddCols"
        Try
            Dim i As Integer

            Dim fields() As FieldInfo
            fields = Row.GetType.GetFields
            For i = 0 To fields.Length - 1
                Select Case fields(i).FieldType.ToString
                    Case "System.String"
                        dTable.Columns.Add(fields(i).Name, System.Type.GetType("System.String"))
                    Case "System.DateTime"
                        dTable.Columns.Add(fields(i).Name, System.Type.GetType("System.DateTime"))
                    Case "System.Boolean"
                        dTable.Columns.Add(fields(i).Name, System.Type.GetType("System.Boolean"))
                    Case "System.Int32"
                        dTable.Columns.Add(fields(i).Name, System.Type.GetType("System.Int32"))
                    Case Else
                        dTable.Columns.Add(fields(i).Name, System.Type.GetType(fields(i).FieldType.ToString))
                End Select
            Next
            dDataSet.Tables.Add(dTable)

            Return dDataSet
        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
        End Try
    End Function
    Private Function DSAddRows(ByRef Row As ValueType, ByVal dTable As DataTable) As DataTable
        Dim ErrLoc As String = ClassName + ".DSAddRows"

        Try
            Dim ds As DataSet
            Dim dr As DataRow = dTable.NewRow()

            Dim i As Integer

            Dim fields() As FieldInfo
            fields = Row.GetType.GetFields
            For i = 0 To fields.Length - 1
                If Not fields(i).GetValue(Row) Is Nothing Then
                    dr(i) = fields(i).GetValue(Row)
                End If
            Next

            dTable.Rows.Add(dr)
            Return dTable
        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
        End Try
    End Function
    Public Function GetDS() As DataSet
        Dim ErrLoc As String = ClassName + ".GetDS"

        Try
            Dim ds As DataSet = New DataSet
            ds.ReadXml(_XMLPath)

            Return ds
        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
        End Try
    End Function
    Public Function GetDS(ByRef Row As ValueType) As DataSet
        Dim ErrLoc As String = ClassName + ".GetDS(Row)"


        Try
            Dim Cols, Rows As Integer
            Dim ds, NewDS As DataSet
            ds = GetDS
            NewDS = GetEmptyDS(Row)

            Dim fields() As FieldInfo
            fields = Row.GetType.GetFields

            Dim CopyRowFlag As Boolean
            For Rows = 0 To ds.Tables(ClassName).Rows.Count - 1
                CopyRowFlag = False
                For Cols = 0 To fields.Length - 1
                    If Not fields(Cols).GetValue(Row) Is Nothing Then
                        Select Case fields(Cols).FieldType.ToString
                            Case "System.String"
                                Dim str, strDS As String
                                str = fields(Cols).GetValue(Row)
                                strDS = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name)
                                If strDS.ToUpper.IndexOf(str.ToUpper) > 0 Then CopyRowFlag = True
                            Case "System.DateTime"
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then CopyRowFlag = True
                            Case "System.Boolean"
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then CopyRowFlag = True
                            Case "System.Int32"
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then CopyRowFlag = True
                            Case Else
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then CopyRowFlag = True
                        End Select
                    End If
                Next
                If CopyRowFlag Then
                    NewDS.Tables(ClassName).Rows.Add(ds.Tables(ClassName).Rows(Rows))
                End If
            Next

            Return NewDS

        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
        End Try

    End Function
    Public Function DeleteAll(ByRef Row As ValueType) As Boolean
        Dim ErrLoc As String = ClassName + ".DeleteAll"

        Try
            Dim ds As DataSet
            ds = GetEmptyDS(Row)
            ds.WriteXml(_XMLPath)

        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
            Return False
        End Try

    End Function
    Public Function Delete(ByRef Row As ValueType) As Boolean
        Dim ErrLoc As String = ClassName + ".Delete"

        Try

            Dim Cols, Rows As Integer
            Dim ds As DataSet
            ds = GetDS()

            Dim fields() As FieldInfo
            fields = Row.GetType.GetFields

            Dim DeleteRowFlag As Boolean
            For Rows = 0 To ds.Tables(ClassName).Rows.Count - 1
                DeleteRowFlag = False
                For Cols = 0 To fields.Length - 1
                    If Not fields(Cols).GetValue(Row) Is Nothing Then
                        Select Case fields(Cols).FieldType.ToString
                            Case "System.String"
                                Dim str, strDS As String
                                str = fields(Cols).GetValue(Row)
                                strDS = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name)
                                If strDS.ToUpper.IndexOf(str.ToUpper) > 0 Then DeleteRowFlag = True
                            Case "System.DateTime"
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then DeleteRowFlag = True
                            Case "System.Boolean"
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then DeleteRowFlag = True
                            Case "System.Int32"
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then DeleteRowFlag = True
                            Case Else
                                If fields(Cols).GetValue(Row) = ds.Tables(ClassName).Rows(Rows)(fields(Cols).Name) Then DeleteRowFlag = True
                        End Select
                    End If
                Next
                If DeleteRowFlag Then
                    ds.Tables(ClassName).Rows(Rows).Delete()
                End If
            Next

            ds.WriteXml(_XMLPath)
            Return True
        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
            Return False
        End Try
    End Function
    Public Function DeleteRecord(ByVal ID As Integer) As Boolean
        Dim ErrLoc As String = ClassName + ".DeleteRecord"

        Try
            Dim Rows As Integer
            Dim ds As DataSet
            ds = GetDS()


            For Rows = 0 To ds.Tables(ClassName).Rows.Count - 1
                If ID = ds.Tables(ClassName).Rows(Rows)(TableIndex) Then
                    ds.Tables(ClassName).Rows(Rows).Delete()
                End If
            Next

            ds.WriteXml(_XMLPath)
            Return True

        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc)
            Return False
        End Try

    End Function
    Public Function ExportCSV(ByVal ExportDir As String, ByRef Row As ValueType) As Boolean
        Dim SQL As String
        Dim ErrLoc As String = ClassName + ".ExportCSV"

        Dim ds As DataSet
        Dim r As DataRow
        Dim StrLine As String

        Try
            REM Get a data of all records
            ds = GetDS()

            REM If there is an error let us know about it
            If ErrMsg <> "" Then MsgBox(ErrMsg)

            REM Create a file name corresponding to the database table name
            Dim fs As FileStream = New FileStream(ExportDir & "\" & ClassName & ".txt", FileAccess.Write)
            Dim w As StreamWriter = New StreamWriter(fs)   ' create a Char writer 

            Dim i As Integer
            Dim Seperator As String = ""
            REM Create Header
            StrLine = ""
            Dim fields() As FieldInfo
            fields = Row.GetType.GetFields
            For i = 0 To fields.Length - 1
                StrLine &= Seperator & fields(i).Name
                Seperator = CSVSeperator
            Next
            w.WriteLine(StrLine)


            REM Check if there are no entries for this patient
            If ds.Tables(ClassName).Rows.Count = 0 Then
                w.WriteLine("EOF")   ' write message
                w.Close()            ' close the writer and underlying file
                REM Let us know that a posible error has happend
                MsgBox("No data in table " & ClassName)
                REM Return successfull because no actuall unexected error happened
                Return True
            End If

            REM Go through data set line by line
            For Each r In ds.Tables(ClassName).Rows '
                StrLine = ""
                Seperator = ""
                REM Read parameters
                For i = 0 To fields.Length - 1
                    StrLine &= Seperator & r(fields(i).Name)
                    Seperator = CSVSeperator
                Next
                w.WriteLine(StrLine)
            Next
            REM Write the End Of File Marker
            w.WriteLine("EOF")
            w.Close()   ' close the writer and underlying file

            REM Return successfull
            Return True

        Catch ex As Exception
            ErrMsg = UnHandledError(ex.ToString(), ErrLoc, SQL)
            Return False
        End Try
    End Function
    Public Function ImportCSV(ByVal ImportDir As String, ByRef Row As ValueType) As Boolean
        Dim ErrLoc As String = ClassName + ".ImportCSV"

        Dim StrTitle As String                    ' Used to verify the header of the file