| Option Strict Off
'zum testen:
'verweis:
'ADOX (Microsoft ADO Ext. 2.x for DDL and Security)
'
'-----------------------------------------------------------------
'
Imports System.Data.OleDb
'
Public Structure tField
'
Public Overrides Function ToString() As String
Return Name
End Function
Public Name As String
Public Type As tField_Type
End Structure
Public Structure tIndex
'
Public Overrides Function ToString() As String
Return Name
End Function
Public Name As String
Public Target_fld As String
End Structure
Public Enum tField_Type
Text_Field
Memo_Field
Integer_Field
Date_Field
Real_Field
Currency_Field
Boolean_Field
SmallInt_Field
single_Field
Binary_Field
_unknown
' Bool_Field nicht nehmen, da access -1 hat, aber sql-server + oracle 1 nehmen!!
End Enum
Public Class DB_MDB_CLS
Private Const vbCrLf As String = Microsoft.VisualBasic.vbCrLf
'
Private cn As OleDbConnection
Private mFilename As String = ""
Private mError As String = ""
Private mSimple_Error As String = ""
'
Public Function Open(ByVal Filename As String) As Boolean
Open = False : mError = ""
Try
Me.Close()
cn = New OleDbConnection("Provider=Microsoft.Jet.OLEDB.4.0; " & _
"Data Source=" & Filename & ";")
cn.Open()
mFilename = Filename
Return True
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Get_SQL_String(ByVal inStr As String) As String
Get_SQL_String = inStr
Try
Get_SQL_String = inStr.Replace("'", "''")
Catch ex As Exception
End Try
End Function
''' <summary>
''' Erstellt aus einer Datenbank eine Textdatei,
''' die via Resorce in das Projekt eingebunden werden kann
''' </summary>
''' <param name="Filename_of_MDB"> Der Name der Access Datei </param>
''' <returns></returns>
''' <remarks></remarks>
Public Function MDB_TO_Text(ByVal Filename_of_MDB As String) As Boolean
MDB_TO_Text = False
Try
Dim Test() As Byte = System.IO.File.ReadAllBytes(Filename_of_MDB)
Dim Ret As String = Convert.ToBase64String(Test)
'
System.IO.File.WriteAllText(Filename_of_MDB & ".txt", Ret)
Return True
Catch : End Try
End Function
Public Function Check_DB(ByVal Filename_of_MDB As String, ByVal Res As _
String) As Boolean
Check_DB = False
Try
If Not IO.File.Exists(Filename_of_MDB) Then
Dim Ret As String = ""
Dim rm As System.Resources.ResourceManager
rm = New Resources.ResourceManager(Me.GetType().Namespace + _
".Resources", _
Me.GetType().Assembly)
'
Ret = rm.GetString(Res)
rm = Nothing
Dim Test() As Byte = Convert.FromBase64String(Ret)
System.IO.File.WriteAllBytes(Filename_of_MDB, Test)
End If
Return True
Catch : End Try
End Function
Public ReadOnly Property Get_Error_Message() As String
Get
Get_Error_Message = ""
Try
Return mError
Catch : End Try
End Get
End Property
Public ReadOnly Property Get_Simple_Error_Message() As String
Get
Get_Simple_Error_Message = ""
Try
Return mSimple_Error
Catch : End Try
End Get
End Property
Public Function Get_SQL_Date(ByVal Data As Date) As String
Get_SQL_Date = "" : mError = ""
Try
'#2/10/2009 23:49:14#
Dim Ret As String = "#" & Microsoft.VisualBasic.Format(Data, _
"MM/dd/yyyy HH:mm:ss") & "#"
Ret = Ret.Replace(".", "/")
Return Ret
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Close() As Boolean
Close = False
Try
If Not cn Is Nothing Then
If cn.State <> 0 Then cn.Close()
cn.Dispose()
End If
cn = Nothing
Return True
Catch : End Try
End Function
Public Function Get_Val(ByVal Field$, ByVal mReader As _
OleDb.OleDbDataReader) As String
Get_Val = "" : mError = ""
Try
If mReader.HasRows Then
If Not Microsoft.VisualBasic.IsDBNull(mReader(Field)) Then
Return mReader(Field).ToString
End If
End If
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Get_AppPath() As String
Get_AppPath = ""
Try
Get_AppPath = "" : mError = ""
Get_AppPath = My.Application.Info.DirectoryPath
If Microsoft.VisualBasic.Right(Get_AppPath, 1) <> "\" Then
Get_AppPath += "\"
End If
Catch : End Try
End Function
Public Function Read(ByVal SQL As String, ByRef mReader As _
OleDb.OleDbDataReader) As Boolean
Read = False : mError = ""
Try
Dim cmd As New OleDbCommand(SQL, cn)
'
If cn Is Nothing Then Exit Function
mReader = cmd.ExecuteReader(CommandBehavior.Default)
cmd = Nothing
Return True
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Get_Table_Names(ByRef Tables() As String) As Integer
Get_Table_Names = -1 : Erase Tables
Try
Dim dbSchemaTable As DataTable = cn.GetOleDbSchemaTable _
(OleDbSchemaGuid.Tables, New Object() _
{Nothing, Nothing, Nothing, "TABLE"})
For Each row As DataRow In dbSchemaTable.Rows
' Console.WriteLine(row("TABLE_NAME"))
Get_Table_Names += 1
ReDim Preserve Tables(Get_Table_Names)
Tables(Get_Table_Names) = CStr(row("TABLE_NAME"))
Next
Return Get_Table_Names + 1
Finally
End Try
End Function
#Region "Export to CSV"
Public Function Export_To_CSV(ByVal Table_Name As String, _
ByVal CSV_Full_filename As String, _
Optional ByVal Seperator As Char = ";") As Boolean
Export_To_CSV = False
Try
'Vorname;Nachname;"Bemerkung;oder so"
'Thomas;Mller;"R”merstr. 18c; 2OG rechts"
'
Dim iCol As Integer, CNT_Col As Integer 'für die feldnamen
Dim OK As Boolean, mReader As Data.OleDb.OleDbDataReader = Nothing
Dim Fields() As tField = Nothing
Dim SQL As String = "SELECT * FROM [" & Table_Name & "]"
Dim mLine As String = "", Value As String = ""
'
'holen der Feldernamen:
CNT_Col = Me.Get_Fields_Info(Table_Name, Fields) - 1
'Datei anlegen
Using FN As New IO.StreamWriter(CSV_Full_filename, False, _
System.Text.Encoding.UTF8)
'GetEncoding(1252)) 'Encoding.UTF8) ' '.GetEncoding(1252))
'Using FS As IO.FileStream = IO.File.Create(CSV_Full_filename)
'Dim preamble = System.Text.Encoding.Unicode.GetPreamble
'FS.Write(preamble, 0, preamble.Length)
'header schreiben:
'Vorname;Nachname;"Bemerkung;oder so"
For iCol = 0 To CNT_Col
mLine += Replace_Sep(Fields(iCol).Name, Seperator)
'; hinten ran, wenns nicht das letzte feld ist
If iCol <> CNT_Col Then
mLine += Seperator
End If
Next
' mLine += vbCrLf
'header schreiben
' Dim data() As Byte = System.Text.Encoding.UTF8.GetBytes(mLine)
'FN.BaseStream.Write(data, 0, data.Length)
FN.WriteLine(mLine)
'FS.Write(data, 0, data.Length)
'
'Datensätze schreiben
'Thomas;Mller;"R”merstr. 18c; 2OG rechts"
OK = Me.Read(SQL, mReader)
While OK AndAlso mReader.Read
mLine = ""
For iCol = 0 To CNT_Col
Value = Me.Get_Val(Fields(iCol).Name, mReader)
mLine += Replace_Sep(Value, Seperator)
'; hinten ran, wenns nicht das letzte feld ist
If iCol <> CNT_Col Then
mLine += Seperator
End If
Next
'mLine += vbCrLf
FN.WriteLine(mLine)
'data = System.Text.Encoding.Unicode.GetBytes(mLine)
'System.Text.Encoding.GetEncoding(1252).GetBytes(mLine)
' System.Text.Encoding.UTF8.GetBytes(mLine)
'FN.WriteLine( mLine)
'FS.Write(data, 0, data.Length)
End While
If OK Then mReader.Close()
mReader = Nothing
'fertig: alle puffer leeren:
FN.Flush()
FN.Close()
End Using
Return True
Catch ex As Exception
End Try
End Function
Private Function Replace_Sep(ByVal Content As String, ByVal Seperator As _
String) As String
Replace_Sep = Content
Try
If Replace_Sep.Contains(Seperator) Then
Replace_Sep = """" & Replace_Sep & """" 'in anführungszeichen setzen
End If
Catch ex As Exception
End Try
End Function
#End Region
Public Function Get_Fields_Info(ByVal Table As String, ByRef Fields() As _
tField) As Integer
Get_Fields_Info = -1 : Erase Fields
Try
'Dim dbSchemaTable As DataTable = cn.GetOleDbSchemaTable _
' (OleDbSchemaGuid.Tables, New Object() _
' {Nothing, Nothing, Nothing, "TABLE"})
'For Each row As DataRow In dbSchemaTable.Rows
' ' Console.WriteLine(row("TABLE_NAME"))
' If row("TABLE_NAME") = Table Then
' For Each fld As DataColumn In row.Field("TABLE_NAME")
' Get_Fields_Names += 1
' ReDim Preserve Fields(Get_Fields_Names)
' Fields(Get_Fields_Names) = CStr(row("TABLE_NAME"))
' Next
' Exit For
' End If
'Next
'Dim SQL As String = "SELECT * FROM [" & Table & "]"
'Dim mReader As OleDb.OleDbDataReader = Nothing, OK As Boolean
''
'OK = Me.Read(SQL, mReader)
''
'For i As Integer = 0 To mReader.FieldCount - 1
' ' Debug.WriteLine(mReader.GetName(i))
' Get_Fields_Names += 1
' ReDim Preserve Fields(Get_Fields_Names)
' Fields(Get_Fields_Names) = mReader.GetName(i)
'Next
'If OK Then mReader.Close()
'mReader = Nothing
Dim schemaTable As DataTable, i As Integer ', DR As DataRow
schemaTable = cn.GetOleDbSchemaTable(OleDbSchemaGuid.Columns, _
New Object() {Nothing, Nothing, Table, Nothing})
'List the column name from each row in the schema table.
For i = 0 To schemaTable.Rows.Count - 1
' Console.WriteLine(schemaTable.Rows(i)!COLUMN_NAME.ToString)
Get_Fields_Info += 1
ReDim Preserve Fields(Get_Fields_Info)
' Fields(Get_Fields_Info) = New tField
Fields(Get_Fields_Info).Name = schemaTable.Rows(i)!COLUMN_NAME.ToString
'Debug.WriteLine(schemaTable.Rows(i)!COLUMN_NAME.ToString & _
' " " & schemaTable.Rows(i)!DATA_TYPE.ToString & _
' " " & schemaTable.Rows(i)!CHARACTER_MAXIMUM_LENGTH.ToString())
With Fields(Get_Fields_Info)
Select Case schemaTable.Rows(i)!DATA_TYPE
Case 3 ' Integer_Spalte 3
.Type = tField_Type.Integer_Field
Case 5 ' Real_Spalte 5
.Type = tField_Type.Real_Field
Case 6 ' Currencey_Spalte 6
.Type = tField_Type.Currency_Field
Case 7 ' Date_Spalte 7
.Type = tField_Type.Date_Field
Case 130
Select Case schemaTable.Rows(i)!CHARACTER_MAXIMUM_LENGTH
Case 0
' Memo_Spalte 130 0
.Type = tField_Type.Memo_Field
Case Else
' Text_Spalte 130 255
.Type = tField_Type.Text_Field
End Select
Case 11 'Boolean
.Type = tField_Type.Boolean_Field
Case 2 'SmallInt
.Type = tField_Type.SmallInt_Field
Case 4 'single
.Type = tField_Type.single_Field
Case 128 'Binary
.Type = tField_Type.Binary_Field
Case Else
.Type = tField_Type._unknown
End Select
End With
Next i
'Dim oledbAdapter As New OleDbDataAdapter("SELECT * FROM [" & Table & "]", cn)
'Dim ds As New DataSet
'Dim dt As DataTable
'oledbAdapter.Fill(ds, "OLEDB Temp Table")
'oledbAdapter.Dispose()
'dt = ds.Tables(0)
'For i = 0 To dt.Columns.Count - 1
' ' MsgBox(dt.Columns(i).ColumnName)
' Debug.WriteLine(dt.Columns(i).ColumnName & " " & _
' dt.Columns(i).DataType.ToString & " " & _
' dt.Columns(i).AllowDBNull & " " & _
' dt.Columns(i).ExtendedProperties.ToString)
'Next
Return Get_Fields_Info + 1
Finally
End Try
End Function
Public Function Get_Table_Info(ByVal Table_Name As String) As DataTable
Get_Table_Info = Nothing
Try
Dim DT As DataTable
Dim Restrictions() As String = {Nothing, Nothing, Table_Name} ' "[" & Table_Name & "]"}
DT = cn.GetSchema("COLUMNS", Restrictions)
For Each row As DataRow In DT.Rows
For Each col As DataColumn In DT.Columns
Console.WriteLine("{0} = {1}", col.ColumnName, row(col))
Next
' Console.WriteLine("============================")
Next
Return DT
Catch ex As Exception
End Try
End Function
Public Function Get_Index_Info(ByVal Table As String) As tIndex()
Get_Index_Info = Nothing
Try
Me.Close()
'
Const adUseClient As Integer = 3
Const adModeShareDenyNone As Integer = 16
Dim xDB As Object 'New ADOX.Catalog ' Object ' Database
Dim xCN As Object 'New ADODB.Connection
Dim CNT As Integer, i As Integer, Ret() As tIndex = Nothing
'
xCN = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADODB.Connection"))
' Server.CreateObject("ADOX.Catalog")
'
With xCN
'.CursorLocation = CType(adUseClient, ADODB.CursorLocationEnum)
mInvoke_prop(xCN, "CursorLocation", New Object() {adUseClient})
'.Mode = CType(adModeShareDenyNone, ADODB.ConnectModeEnum)
mInvoke_prop(xCN, "Mode", New Object() {adModeShareDenyNone})
'.Provider = "Microsoft.Jet.OLEDB.4.0"
mInvoke_prop(xCN, "Provider", New Object() _
{"Microsoft.Jet.OLEDB.4.0"})
'.ConnectionString = "Data Source=" & mFilename & ""
mInvoke_prop(xCN, "ConnectionString", New Object() _
{"Data Source=" & mFilename})
'.Open()
mInvoke(xCN, "Open", Nothing)
End With
'Create object and connect to DB...
xDB = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADOX.Table"))
mInvoke_prop(xDB, "ActiveConnection", New Object() {xCN})
''Change the name...
'xDB.Tables(Old_Name).Name = New_Name
'Dim xDB As New ADOX.Table
CNT = xDB.Indexes.Count - 1
If CNT > -1 Then
ReDim Ret(0 To CNT)
End If
For i = 0 To CNT
Ret(i) = New tIndex
Ret(i).Name = xDB.Indexes(0).Name
Ret(i).Target_fld = xDB.Indexes(0).Columns(0)
Next
xDB = Nothing
mInvoke(xCN, "Close", Nothing)
xCN = Nothing
'reopen
Me.Open(mFilename)
'
Application.DoEvents()
'
Return Ret
Catch ex As Exception
End Try
End Function
Public Function Rename_Table(ByVal Old_Name As String, ByVal New_Name As _
String) As Boolean
Rename_Table = False
Try
Me.Close()
'
Const adUseClient As Integer = 3
Const adModeShareDenyNone As Integer = 16
Dim xDB As Object 'New ADOX.Catalog ' Object ' Database
Dim xCN As Object 'New ADODB.Connection
'
xCN = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADODB.Connection"))
' Server.CreateObject("ADOX.Catalog")
'
With xCN
'.CursorLocation = CType(adUseClient, ADODB.CursorLocationEnum)
mInvoke_prop(xCN, "CursorLocation", New Object() {adUseClient})
'.Mode = CType(adModeShareDenyNone, ADODB.ConnectModeEnum)
mInvoke_prop(xCN, "Mode", New Object() {adModeShareDenyNone})
'.Provider = "Microsoft.Jet.OLEDB.4.0"
mInvoke_prop(xCN, "Provider", New Object() _
{"Microsoft.Jet.OLEDB.4.0"})
'.ConnectionString = "Data Source=" & mFilename & ""
mInvoke_prop(xCN, "ConnectionString", New Object() _
{"Data Source=" & mFilename})
'.Open()
mInvoke(xCN, "Open", Nothing)
End With
'Create object and connect to DB...
xDB = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADOX.Catalog"))
' Server.CreateObject("ADOX.Catalog")
' mInvoke_prop(xDB, "ActiveConnection", New Object() { _
' "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & mFilename})
'xDB.ActiveConnection = xCN ' "Provider=Microsoft.Jet.OLEDB.4.0;" _
'& "Data(Source = " & mFilename")
mInvoke_prop(xDB, "ActiveConnection", New Object() {xCN})
'Change the name...
xDB.Tables(Old_Name).Name = New_Name
' mInvoke_prop(xDB, "Tables(" & Old_Name & ").Name", _
' New Object() {New_Name})
'Debug.WriteLine(xDB.GetType().InvokeMember("Tables", _
' Reflection.BindingFlags.GetProperty Or _
' Reflection.BindingFlags.Instance Or Reflection. _
' BindingFlags.[Public], Nothing, xDB, _
' New Object() {Old_Name}).GetType().InvokeMember _
' ("Name", Reflection.BindingFlags.SetProperty Or _
' Reflection.BindingFlags.Instance Or Reflection. _
' BindingFlags.[Public], Nothing, xDB, _
' New Object() {New_Name}))
'.GetType().InvokeMember("Name", _
' Reflection.BindingFlags.SetProperty Or _
' Reflection.BindingFlags.Instance Or _
' Reflection.BindingFlags.[Public], _
' Nothing, xDB, New Object() {New_Name}))
xDB = Nothing
'xCN.Close()
mInvoke(xCN, "Close", Nothing)
xCN = Nothing
'reopen
Me.Open(mFilename)
Catch ex As Exception
End Try
End Function
Public Function Rename_Field(ByVal Table As String, ByVal Old_Name As _
String, ByVal New_Name As String) As Boolean
Rename_Field = False
Try
Me.Close()
'
Const adUseClient As Integer = 3
Const adModeShareDenyNone As Integer = 16
Dim xDB As New Object 'ADOX.Catalog ' 'Object '
Dim xCN As Object 'New ADODB.Connection
'
xCN = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADODB.Connection"))
' Server.CreateObject("ADOX.Catalog")
'
With xCN
'.CursorLocation = CType(adUseClient, ADODB.CursorLocationEnum)
mInvoke_prop(xCN, "CursorLocation", New Object() {adUseClient})
'.Mode = CType(adModeShareDenyNone, ADODB.ConnectModeEnum)
mInvoke_prop(xCN, "Mode", New Object() {adModeShareDenyNone})
'.Provider = "Microsoft.Jet.OLEDB.4.0"
mInvoke_prop(xCN, "Provider", New Object() {"Microsoft.Jet." _
& "OLEDB.4.0"})
'.ConnectionString = "Data Source=" & mFilename & ""
mInvoke_prop(xCN, "ConnectionString", New Object() _
{"Data Source=" & mFilename})
'.Open()
mInvoke(xCN, "Open", Nothing)
End With
'Create object and connect to DB...
xDB = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADOX.Catalog"))
' Server.CreateObject("ADOX.Catalog")
' mInvoke_prop(xDB, "ActiveConnection", New Object() { _
' "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & mFilename})
'xDB.ActiveConnection = xCN ' "Provider=Microsoft.Jet.OLEDB.4.0;" _
' & "Data Source= " & mFilename
mInvoke_prop(xDB, "ActiveConnection", New Object() {xCN})
'Change the name...
xDB.Tables(Table).Columns(Old_Name).Name = New_Name
xDB = Nothing
'xCN.Close()
mInvoke(xCN, "Close", Nothing)
xCN = Nothing
'reopen
Me.Open(mFilename)
Catch ex As Exception
End Try
End Function
Public Function Drop_Field(ByVal Table As String, ByVal Field_Name As _
String) As Boolean
Drop_Field = False
Try
Me.Close()
'
Const adUseClient As Integer = 3
Const adModeShareDenyNone As Integer = 16
Dim xDB As Object 'New ADOX.Catalog 'ADOX.Catalog ' 'Object '
Dim xCN As Object 'New ADODB.Connection
Dim Tbl As Object
'
xCN = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADODB.Connection"))
' Server.CreateObject("ADOX.Catalog")
'
With xCN
'.CursorLocation = CType(adUseClient, ADODB.CursorLocationEnum)
mInvoke_prop(xCN, "CursorLocation", New Object() {adUseClient})
'.Mode = CType(adModeShareDenyNone, ADODB.ConnectModeEnum)
mInvoke_prop(xCN, "Mode", New Object() {adModeShareDenyNone})
'.Provider = "Microsoft.Jet.OLEDB.4.0"
mInvoke_prop(xCN, "Provider", New Object() {"Microsoft.Jet." _
& "OLEDB.4.0"})
'.ConnectionString = "Data Source=" & mFilename & ""
mInvoke_prop(xCN, "ConnectionString", New Object() _
{"Data Source=" & mFilename})
'.Open()
mInvoke(xCN, "Open", Nothing)
End With
'Create object and connect to DB...
xDB = Activator.CreateInstance(Type.GetTypeFromProgID _
("ADOX.Catalog"))
' Server.CreateObject("ADOX.Catalog")
' mInvoke_prop(xDB, "ActiveConnection", New Object() { _
' "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " & mFilename})
'xDB.ActiveConnection = xCN ' "Provider=Microsoft.Jet.OLEDB.4.0;" _
' & "Data Source= " & mFilename
mInvoke_prop(xDB, "ActiveConnection", New Object() {xCN})
'Change the name...
Tbl = xDB.Tables(Table)
' Drop the field.
Tbl.Columns.Delete(Field_Name)
Tbl = Nothing
xDB = Nothing
'xCN.Close()
mInvoke(xCN, "Close", Nothing)
xCN = Nothing
'reopen
Me.Open(mFilename)
Catch ex As Exception
End Try
End Function
Public ReadOnly Property Is_Opened() As Boolean
Get
Is_Opened = False
Try
If Not cn Is Nothing Then
Return True
End If
Catch ex As Exception
End Try
End Get
End Property
Public Function Datatable(ByVal SQL As String) As DataTable
Datatable = New DataTable : mError = ""
Try
SQL = Clean_SQL(SQL)
Dim DA As New OleDb.OleDbDataAdapter(SQL, cn)
Datatable.Locale = System.Globalization.CultureInfo.InvariantCulture
DA.Fill(Datatable)
DA = Nothing
Catch ex As Exception
' If Microsoft.VisualBasic.Err.Number = 5 Then
'MessageBox.Show("Please open a database first!", "", _
' MessageBoxButtons.OK, MessageBoxIcon.Information)
' Else
mError = ex.StackTrace & vbCrLf & ex.Message
mSimple_Error = ex.Message
'Debug.WriteLine(Microsoft.VisualBasic.Err.Number)
' End If
Return Nothing
End Try
End Function
Public Function DataAdapter(ByVal SQL As String) As OleDbDataAdapter
mError = ""
Try
SQL = Clean_SQL(SQL)
Dim DA As New OleDb.OleDbDataAdapter(SQL, cn)
Return DA
Catch ex As Exception
' If Microsoft.VisualBasic.Err.Number = 5 Then
'MessageBox.Show("Please open a database first!", "", _
' MessageBoxButtons.OK, MessageBoxIcon.Information)
' Else
mError = ex.StackTrace & vbCrLf & ex.Message
mSimple_Error = ex.Message
'Debug.WriteLine(Microsoft.VisualBasic.Err.Number)
' End If
Return Nothing
End Try
End Function
Private Function Clean_SQL(ByVal SQL As String) As String
Clean_SQL = SQL
Try
Dim Start As Integer, Ende As Integer
'
Start = SQL.IndexOf("/*")
While Start <> -1
Ende = SQL.IndexOf("*/")
SQL = SQL.Substring(0, Start) & " " & SQL.Substring(Ende + 2)
Start = SQL.IndexOf("/*")
End While
Return SQL
Catch ex As Exception
End Try
End Function
Public Function Get_Entry(ByVal x As Object) As String
Get_Entry = ""
Try
If Microsoft.VisualBasic.IsDBNull(x) Then
Return ""
Else
Return x.ToString
End If
Catch ex As Exception
End Try
End Function
Public Function Read_Single_Value(ByVal SQL As String) As String
Read_Single_Value = "" : mError = ""
Try
Dim cmd As New OleDbCommand(SQL, cn)
Dim Ret As Object
'
If cn Is Nothing Then Exit Function
Ret = cmd.ExecuteScalar
If Not Ret Is Nothing Then
Return Ret.ToString
End If
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Get_Record_Count(ByVal SQL As String) As Integer
Get_Record_Count = 0 : mError = ""
Try
Dim mSQL As String = "SELECT COUNT(*) FROM (" & SQL & ")"
Dim Ret As String = Me.Read_Single_Value(mSQL)
If Microsoft.VisualBasic.IsNumeric(Ret) Then
Return CInt(Ret)
End If
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Delete(ByVal Where_SQL As String, _
ByVal TableName As String) As Integer
Delete = -1 : mError = ""
Try
Dim SQL As String
SQL = "DELETE FROM " & TableName
SQL += " " & Where_SQL
Dim cmd As New OleDb.OleDbCommand(SQL, cn)
Delete = cmd.ExecuteNonQuery
cmd = Nothing
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Overloads Function Update(ByVal Fields() As String, _
ByVal Values() As String, _
ByVal Where_SQL As String, _
ByVal TableName As String) As Integer
Update = -1 : mError = ""
Try
Dim SQL As String = "", i As Integer, CNT As Integer, mVal As String = ""
SQL = "UPDATE " & TableName & " SET"
CNT = Fields.Length - 1
For i = 0 To CNT
If Values(i) <> "" Then
If Values(i).Trim.Substring(0, 1) <> "#" AndAlso _
Values(i).Trim.Substring(Values(i).Trim.Length - 1, 1) _
<> "#" Then
mVal = "'" & Values(i).Replace("'", "''") & "'"
Else
mVal = Values(i)
End If
Else
mVal = "NULL"
End If
SQL += " [" & Fields(i) & "]=" & mVal ', "'", "''")
If i <> CNT Then SQL += ","
Next
SQL = SQL & " " & Where_SQL
Dim cmd As New OleDb.OleDbCommand(SQL, cn)
Update = cmd.ExecuteNonQuery
cmd = Nothing
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Execute(ByVal SQL As String) As Boolean
Execute = False
Try
Dim ret As Integer, OK As Boolean
Dim cmd As New OleDb.OleDbCommand(SQL, cn)
'
ret = cmd.ExecuteNonQuery
cmd = Nothing
If ret = 1 Then
OK = True
Else
OK = False
End If
Return ok
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function Insert(ByVal Fields() As String, _
ByVal Values() As String, ByVal TableName As String) As Integer
Insert = -1 : mError = "" 'error
Dim SQL As String = ""
Try
Dim i As Integer, CNT As Integer
Dim aSQL As String, bSql As String, mVal As String = ""
'
SQL = "INSERT INTO " & TableName
aSQL = " (" : bSql = "VALUES("
CNT = Fields.Length - 1
For i = 0 To CNT
aSQL += "[" & Fields(i) & "]"
If i <> CNT Then aSQL += ","
If Values(i) <> "" Then
If Values(i).Trim.Substring(0, 1) <> "#" AndAlso _
Values(i).Trim.Substring(Values(i).Trim.Length - 1, 1) _
<> "#" Then
mVal = "'" & Values(i).Replace("'", "''") & "'"
Else
mVal = Values(i)
End If
Else
mVal = "NULL"
End If
bSql += mVal
If i <> CNT Then bSql += ","
Next
aSQL += ")"
bSql += ")"
SQL += aSQL & bSql
Dim cmd As New OleDb.OleDbCommand(SQL, cn)
Insert = cmd.ExecuteNonQuery
cmd = Nothing
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
End Try
End Function
Public Function CreateDatabase(ByVal DB_FullName As String, ByVal _
Table_Name As String) As Boolean
CreateDatabase = False
Try
'Dim Engine As Object
Dim oParams() As Object
Dim objJRO As Object = _
Activator.CreateInstance(Type.GetTypeFromProgID("ADOX.Catalog"))
'
oParams = New Object() _
{"Provider=Microsoft.Jet.OLEDB.4.0;Jet OLEDB:Engine Type=5;Data" _
& " Source=" + DB_FullName + ";"}
'
objJRO.GetType().InvokeMember("Create", _
System.Reflection.BindingFlags.InvokeMethod, _
Nothing, objJRO, oParams)
'
oParams = Nothing
objJRO = Nothing
Me.Open(DB_FullName)
CreateDatabase = Create_Table(Table_Name)
Catch ex As Exception
End Try
End Function
Private Function mInvoke(ByRef mObject As Object, ByVal mMethode As String, _
ByVal Paras() As Object) As Boolean
mInvoke = False
Try
mObject.GetType().InvokeMember(mMethode, _
System.Reflection.BindingFlags.InvokeMethod, _
Nothing, mObject, Paras)
Return True
Catch ex As Exception
End Try
End Function
Private Function mInvoke_prop(ByRef mObject As Object, ByVal mProperty As _
String, ByVal Paras() As Object) As Boolean
mInvoke_prop = False
Try
'mObject.GetType().InvokeMember(mMethode, _
' System.Reflection.BindingFlags.SetProperty, _
' Nothing, mObject, Paras)
mObject.GetType().InvokeMember(mProperty, _
Reflection.BindingFlags.SetProperty Or _
Reflection.BindingFlags.Instance Or Reflection. _
BindingFlags.[Public], Nothing, mObject, Paras)
Return True
Catch ex As Exception
End Try
End Function
Public Function Drop_Table(ByVal Table_Name As String) As Boolean
Drop_Table = False
Try
Dim Ret As String
Dim SQL As String = "drop table [" & Table_Name & "]"
'
Ret = Me.Read_Single_Value(SQL)
Return True
Catch ex As Exception
End Try
End Function
Public Function Create_Table(ByVal Table_Name As String) As Boolean
Create_Table = False
Try
' Dim Cn As New Object 'ADODB.Connection
Dim SqlSatement As String = ""
'
' Cn = Activator.CreateInstance(Type.GetTypeFromProgID _
' ("ADODB.Connection"))
'Open the connection
' cn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_FullName)
'mInvoke(Cn, "Open", New Object() {"Provider=Microsoft.Jet.OLEDB.4" _
' & ".0;Data Source=" & DB_FullName})
'
SqlSatement = "CREATE TABLE " & Table_Name & " ("
SqlSatement += " ID autoincrement NOT NULL )"
'AUTOINCREMENT PRIMARY KEY)"
'mInvoke(Cn, "Execute", New Object() {SqlSatement})
Me.Read_Single_Value(SqlSatement)
'mInvoke(Cn, "Close", Nothing)
'
'Cn = Nothing
'
Return True
Catch ex As Exception
End Try
End Function
Public Function Create_Index(ByVal DB_FullName As String, ByVal Table_Name _
As String, ByVal Field_Name As String) As Boolean
Create_Index = False
Try
Dim Cn As New Object 'ADODB.Connection
Dim SqlSatement As String = ""
'
Cn = Activator.CreateInstance(Type.GetTypeFromProgID("ADODB.Connection"))
'Open the connection
'Cn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_FullName)
mInvoke(Cn, "Open", New Object() {"Provider=Microsoft.Jet.OLEDB.4.0" _
& ";Data Source=" & DB_FullName})
'
SqlSatement = "CREATE UNIQUE INDEX " & Field_Name & "_IDX " _
& "ON " & Table_Name & " (" & Field_Name & ") "
mInvoke(Cn, "Execute", New Object() {SqlSatement})
'Cn.Execute(SqlSatement)
mInvoke(Cn, "Close", Nothing)
'
Cn = Nothing
'
Return True
Return True
Catch ex As Exception
End Try
End Function
Public Function Create_Field(ByVal DB_FullName As String, ByVal Table_Name _
As String, ByVal Field_Name As String, _
ByVal Field_Type As tField_Type) As Boolean
Create_Field = False
Try
Dim Cn As New Object 'ADODB.Connection
Dim SqlSatement As String = ""
'
Cn = Activator.CreateInstance(Type.GetTypeFromProgID("ADODB.Connection"))
'Open the connection
'Cn.Open("Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & DB_FullName)
mInvoke(Cn, "Open", New Object() {"Provider=Microsoft.Jet.OLEDB.4.0" _
& ";Data Source=" & DB_FullName})
'
SqlSatement = "ALTER TABLE [" & Table_Name & "] ADD COLUMN [" _
& Field_Name.Trim & "] "
'ALTER TABLE Employees ADD COLUMN Notes TEXT(25)
' autoincrement NOT NULL )" 'AUTOINCREMENT PRIMARY KEY)"
Select Case Field_Type
Case tField_Type.Date_Field
SqlSatement += "DATE"
Case tField_Type.Integer_Field
SqlSatement += "INTEGER"
Case tField_Type.Memo_Field
SqlSatement += "MEMO"
Case tField_Type.Real_Field
SqlSatement += "DOUBLE"
Case tField_Type.Text_Field
SqlSatement += "TEXT (255)"
'Case tField_Type.Bool_Field
' SqlSatement += "YESNO"
Case tField_Type.Currency_Field
SqlSatement += "CURRENCY"
End Select
mInvoke(Cn, "Execute", New Object() {SqlSatement})
'Cn.Execute(SqlSatement)
mInvoke(Cn, "Close", Nothing)
'
Cn = Nothing
'
Return True
Return True
Catch ex As Exception
End Try
End Function
Public Function CompactAccessDB() As Boolean
CompactAccessDB = False : mError = ""
Try
Dim oParams() As Object
Dim TempFile As String = System.IO.Path.GetTempFileName() & ".mdb"
Dim objJRO As Object = _
Activator.CreateInstance(Type.GetTypeFromProgID("JRO.JetEngine"))
Dim CN_Str As String = cn.ConnectionString
Me.Close()
oParams = New Object() { _
CN_Str, _
"Provider=Microsoft.Jet.OLEDB.4.0;Data" & _
" Source=" & TempFile & ";Jet OLEDB:Engine Type=5"}
objJRO.GetType().InvokeMember("CompactDatabase", _
System.Reflection.BindingFlags.InvokeMethod, _
Nothing, _
objJRO, _
oParams)
System.IO.File.Delete(mFilename)
System.IO.File.Move(TempFile, mFilename)
System.Runtime.InteropServices.Marshal.ReleaseComObject(objJRO)
objJRO = Nothing
Return True
Catch ex As Exception
mError = ex.StackTrace & vbCrLf & ex.Message
Finally
Try
Open(mFilename)
Catch : End Try
End Try
End Function
End Class
|
