by Anton Oey (2 Submissions)
Category: Databases/Data Access/DAO/ADO
Compatability: VB 6.0
Difficulty: Unknown Difficulty
Originally Published: Sun 4th November 2001
Date Added: Mon 8th February 2021
Rating: 
(1 Votes)
Convert Excel to Access
API Declarations
Private Sub Command1_Click()
Dim boolResult As Boolean
Dim myConv As Object
Dim Directory As String
Directory = Left$(App.Path, 3)
Set myConv = New DoConversion
With myConv
.FileName = "Chemistry"
.XLSFilename = "Chemistry.xls"
.Sheetname = "Chemlist"
.ExcelDir = Directory
.AccessDir = Directory
.InitialField = "Chemical Name"
.MaximumCol = 15
.AccessVersion = 2
.ConvertType = 1
boolResult = .Execute()
If boolResult = True Then
MsgBox ("Status : OK")
Else
MsgBox ("Status : Fail")
End If
End With
Set myConv = Nothing
End Sub
VBcoders
'I don't responsible if something weird happens
'If you found bug please let me know : [email protected]
'This version just handles excel to excess
'
'To use this .dll, just go to project, references, the locate Conversion.dll
'
'Property that you have to setup:
' Dim myConv As Object
' Dim boolResult As Boolean
' Dim myConv As Object
' Set myConv = New DoConversion
' With myConv
' .Filename = "blablabla" just excel filename without .xls
' .XLSFilename = "blablabla.xls" excel file name
' .Sheetname = "blabla" excel sheet name
' .ExcelDir = "c:\xls\" anything you like
' .AccessDir = "c:\access\" anything you like
' .InitialField = "Description" start from what variable
' do you want to convert
' .MaximumCol = 15 to detect max col
' .AccessVersion = 2
' .ConvertType = 1
' boolResult = .Execute()
' If boolResult = True Then
' lstResult.AddItem "Status : OK"
' Else
' lstResult.AddItem "Status : Fail"
' End If
' End With
' Set myConv = Nothing
'For ConvertType, only value 1 available
'For AccessVersion -> 0 for old office, 1 for office 97, 2 for office 2000
Dim L_XLSFname As String
Dim TypeConvert As Integer
Dim L_Fname As String
Dim L_Sname As String
Dim X_Dir As String
Dim A_Dir As String
Dim StartFrom As String
Dim MaxCol As Integer
Dim TypeAccess As String
Dim LastResult As Boolean
Public Property Let XLSFilename(ByVal O_XLSFname As String)
L_XLSFname = O_XLSFname
End Property
Public Property Let Filename(ByVal O_Fname As String)
L_Fname = O_Fname
End Property
Public Property Let Sheetname(ByVal O_Sname As String)
L_Sname = O_Sname
End Property
Public Property Let ExcelDir(ByVal O_Xdir As String)
X_Dir = O_Xdir
End Property
Public Property Let AccessDir(ByVal O_Adir As String)
A_Dir = O_Adir
End Property
Public Property Let InitialField(ByVal O_Start As String)
StartFrom = O_Start
End Property
Public Property Let AccessVersion(ByVal O_AccVer As Integer)
TypeAccess = O_AccVer
End Property
Public Property Let MaximumCol(ByVal nCol As Integer)
MaxCol = nCol
End Property
Public Property Let ConvertType(ByVal nType As Integer)
TypeConvert = nType
End Property
Public Function Execute() As Boolean
LastResult = True
Duplicate
Execute = LastResult
End Function
Private Function Duplicate()
On Error GoTo finish
Dim MyWs As Workspace
Dim MyDb As Database
Set MyWs = DBEngine.Workspaces(0)
Select Case TypeConvert
Case 1
If Dir(A_Dir & L_Fname & ".mdb") <> "" Then
Kill (A_Dir & L_Fname & ".mdb")
End If
Select Case TypeAccess
Case 0
Set MyDb = MyWs.CreateDatabase(A_Dir & L_Fname & ".mdb", dbLangGeneral, dbVersion40)
Case 1
Set MyDb = MyWs.CreateDatabase(A_Dir & L_Fname & ".mdb", dbLangGeneral, dbVersion50)
Case 2
Set MyDb = MyWs.CreateDatabase(A_Dir & L_Fname & ".mdb", dbLangGeneral, dbVersion60)
Case Else
LastResult = False
End Select
Set MyWs = Nothing
Set MyDb = Nothing
DoExcelAccess
Case Else
End Select
If LastResult = True Then GoTo done
finish:
If Dir(A_Dir & L_Fname & ".mdb") <> "" Then
Kill (A_Dir & L_Fname & ".mdb")
End If
LastResult = False
done:
End Function
Private Function DoExcelAccess()
On Error GoTo finish
Dim cnn As New ADODB.Connection
Dim path As String
Dim Sheet As Object
Dim r, y, x, n, count As Integer
Dim Xstart, Ystart, Xend, Yend, tempX, tempY As Integer
Dim flagX As Boolean
Dim flagY As Integer
Dim XFields() As String
Dim Fieldname, ans As String
Dim LengthField As Integer
Dim Query As String
Dim Combined As String
Dim aByte As String
Dim LengthCombined As String
Dim ComResult As String
path = X_Dir & L_XLSFname
If Dir(path) = "" Then
MsgBox (path & " doesn't exist.")
LastResult = False
End If
If LastResult = False Then GoTo finish
flagX = True
Set Sheet = GetObject(path, "Excel.Sheet.8") 'assign sheet object as an OLE excel
With Sheet.Worksheets(L_Sname)
y = 1
z = 0
flagY = 1
Xstart = 0
Xend = 0
Ystart = 0
Yend = 0
count = 0
Fieldname = ""
ReDim XFields(count)
Do While True
If flagX = True Then
For x = 1 To MaxCol
If Trim(LCase(.cells(y, x).Value)) = LCase(StartFrom) And flagX = True Then
Xstart = x
Ystart = y
tempX = x
tempY = y
Do While True
If Trim(.cells(tempY, tempX).Value) = "" Then
Xend = tempX - 1
Exit Do
End If
tempX = tempX + 1
Loop
flagX = False
Exit For
End If
Next
If flagX = True And y = 20 * flagY Then
ans = MsgBox("MyInventory couldn't find " & StartFrom & _
" up to line " & y & ". Continue?", vbYesNo + vbQuestion)
If ans = vbNo Then
MsgBox ("Go to Property to fix this error.")
LastResult = False
Exit Do
End If
flagY = flagY + 1
End If
Else
For n = Xstart To Xend
ComResult = ""
aByte = ""
Combined = Trim(.cells(Ystart, n).Value)
LengthCombined = Len(Combined)
For r = 0 To LengthCombined
aByte = Mid(Combined, r + 1, 1)
If aByte <> ")" And aByte <> "(" And aByte <> "." And aByte <> " " And aByte <> "#" Then
ComResult = ComResult & aByte
End If
Next r
XFields(count) = Trim(ComResult)
Fieldname = Fieldname & " " & Trim(ComResult) & " Text(150)" & ","
count = count + 1
ReDim Preserve XFields(count)
Next
LengthField = Len(Trim(Fieldname))
Fieldname = Left(Trim(Fieldname), LengthField - 1)
If LengthField > 0 Then
Query = "Create Table " + L_Sname + " ( " + Fieldname + " )"
cnn.Open "provider=microsoft.jet.oledb.4.0;data source=" & A_Dir & L_Fname & ".mdb"
cnn.Execute Query
Exit Do
Else
MsgBox ("Undefined error.")
LastResult = False
Exit Do
End If
End If
y = y + 1
Loop
If LastResult = False Then GoTo finish
Dim dataRec As ADODB.Recordset
Set dataRec = New ADODB.Recordset
dataRec.Open L_Sname, cnn, adOpenStatic, adLockOptimistic, adCmdTable
Ystart = Ystart + 1
Do While True
If .cells(Ystart, Xstart) = "" Then
Exit Do
End If
z = Xstart
dataRec.AddNew
For x = 0 To count - 1
dataRec(XFields(x)) = .cells(Ystart, z).Value
z = z + 1
Next
dataRec.Update
Ystart = Ystart + 1
Loop
End With
Set dataRec = Nothing
Set cnn = Nothing
Set Sheet = Nothing
If LastResult = True Then GoTo done
finish:
If Dir(A_Dir & L_Fname & ".mdb") <> "" Then
Kill (A_Dir & L_Fname & ".mdb")
End If
LastResult = False
done:
Set dataRec = Nothing
Set cnn = Nothing
Set Sheet = Nothing
End Function
