'********************* Start Module ReadExcel Variable (This declare in module file.)
Public arrExcelColumnName() As String
Public arrExcelSheetName() As String
Public rsExcelData As ADODB.Recordset
Public arrValues(,) As String
'********************* End Module ReadExcel Variable
Module modReadExcel
Public adoConn As ADODB.Connection
Public rs As ADODB.Recordset
Dim mrstrConString As String
Dim strFilePath As String
Public Sub SetFilePath(ByVal Value As String)
Try
Dim objFso
objFso = CreateObject("Scripting.FileSystemObject")
If objFso.FileExists(Value) = True Then
strFilePath = Value
End If
Catch ex As Exception
MessageBox.Show("Error Is Found In : " & vbCrLf & " Module Name : SetFilePath " & vbCrLf & _
"Error Description : " & ex.Message)
End Try
End Sub
Public Sub SetConnectionString(ByVal Value As String)
SetFilePath(Value)
If strFilePath <> "" Then
If InStr(1, strFilePath, ".xlsx") > 0 Then
mrstrConString = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & strFilePath & ";Extended Properties=""Excel 12.0;HDR=YES"""
ElseIf InStr(1, strFilePath, ".xls") > 0 Then
mrstrConString = "DRIVER=Microsoft Excel Driver (*.xls);" & "DBQ=" & strFilePath
End If
Else
mrstrConString = ""
End If
End Sub
Public Function SetConnection(ByVal sEnum As ADODB.SchemaEnum, Optional ByVal SheetName As String = Nothing) As Boolean
Try
SetConnection = False
If mrstrConString = "" Then
SetConnectionString()
If mrstrConString = "" Then
SetConnection = False
Exit Function
End If
End If
adoConn = Nothing
adoConn = New ADODB.Connection
adoConn.CursorLocation = 1
adoConn.Open(mrstrConString)
Dim arr(0 To 3) As Object
Dim Catalog As Object
Dim Schema As Object
Dim TableName As Object
Dim TableType As Object
Catalog = Nothing
Schema = Nothing
TableName = SheetName
TableType = Nothing
arr(0) = Catalog
arr(1) = Schema
arr(2) = TableName
arr(3) = TableType
rs = adoConn.OpenSchema(sEnum, arr)
SetConnection = True
Catch ex As Exception
SetConnection = False
MessageBox.Show("Error Is Found In : " & vbCrLf & " Module Name : SetConnection" & vbCrLf & _
"Error Description : " & ex.Message)
End Try
End Function
Public Sub GetSheetName()
Dim arrlocal() As String
Try
SetConnection(ADODB.SchemaEnum.adSchemaTables)
ReDim Preserve arrlocal(0)
Dim i As Integer = 0
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst()
While (rs.EOF = False)
arrlocal(i) = rs.Fields("TABLE_NAME").Value & ""
ReDim Preserve arrlocal(UBound(arrlocal) + 1)
i += 1
rs.MoveNext()
End While
ReDim Preserve arrExcelSheetName(UBound(arrlocal) - 1)
For i = LBound(arrlocal) To UBound(arrlocal) - 1
arrExcelSheetName(i) = arrlocal(i)
Next
End If
Catch ex As Exception
Finally
arrlocal = Nothing
End Try
End Sub
Public Sub GetExcelColumnName(ByVal SheetName As String)
SetConnection(ADODB.SchemaEnum.adSchemaColumns, SheetName)
arrExcelColumnName = Nothing
ReDim Preserve arrExcelColumnName(0)
Dim i As String = 0
If Not (rs.BOF And rs.EOF) Then
rs.MoveFirst()
While (rs.EOF = False)
arrExcelColumnName(i) = rs.Fields("COLUMN_NAME").Value & ""
ReDim Preserve arrExcelColumnName(UBound(arrExcelColumnName) + 1)
i += 1
rs.MoveNext()
End While
End If
End Sub
Public Sub GetExcelData(ByVal SheetName As String, Optional ByVal SpColumnName As String = "[AllData]")
Try
SetConnection(ADODB.SchemaEnum.adSchemaColumns, SheetName)
Dim i As Integer, j As Integer
rsExcelData = Nothing
rsExcelData = New ADODB.Recordset
If InStr(1, SpColumnName, ",") > 0 Then
SpColumnName = "[" & Replace(SpColumnName, ",", "],[") & "]"
End If
If SpColumnName.ToUpper() = "[AllData]".ToUpper() Then
rsExcelData.Open("SELECT * FROM [" & SheetName & "]", mrstrConString, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockReadOnly)
ElseIf SpColumnName.ToUpper().Trim() <> "" Then
rsExcelData.Open("SELECT " & SpColumnName & " FROM [" & SheetName & "]", mrstrConString, ADODB.CursorTypeEnum.adOpenStatic, ADODB.LockTypeEnum.adLockReadOnly)
End If
arrValues = Nothing
ReDim arrValues(Convert.ToInt64(rsExcelData.Fields.Count), 0)
For i = 0 To rsExcelData.RecordCount - 1
For j = 0 To rsExcelData.Fields.Count - 1
arrValues(j, i) = Trim$(rsExcelData.Fields(j).Value & " ")
Next
rsExcelData.MoveNext()
ReDim Preserve arrValues(Convert.ToInt64(rsExcelData.Fields.Count), UBound(arrValues, 2) + 1)
Next
Catch ex As Exception
If InStr(1, ex.Message, "Too few parameters") > 0 Then
MessageBox.Show("Invalid Column Name." & vbCrLf & ex.Message)
ElseIf InStr(1, ex.Message, "in date in query expression") > 0 Then
MessageBox.Show("Invaild query expression." & vbCrLf & Err.Description)
Else
MessageBox.Show("Error Found. " & vbCrLf & Err.Description)
End If
arrValues = Nothing
End Try
End Sub
End Module
No comments:
Post a Comment