Import Unicode UTF-8 Text Directly into Access Using VBA
The power, convenience and autmation of MS Access makes it the perfect tool for manipulating data during a data migration project. Its native support makes it even more powerful when dealing with an international project.
Manually importing extracted data opens the door to errors, delays and failed projects. A common best practice is to eliminate manual steps whenever possible and including the import as a step in a macro eliminates the risk of that step being forgotten.
Most of this code is recycled from a 2011 snippet that imported ANSI text directly into an Access table using VBA. That function only imports garbled mess when attempting to import Unicode.
The status bar functions that predict the amount of time remaining are moot today because networks and computers are blistering fast compared to what was available in 2011; it might take several minutes to import a text file on a share in another country, but today it takes mere seconds. The functionality is left in just as it does not slow down the process and might someday help a programmer decide whether or not to go for a coffee.
The source code
Naturally, this has already been included in Jimbo's VBA Automation Toolbox, but it is included here for those who simply want to copy-paste. It relies on a supplementary function called CreateTable() function which is included below.
There are a few extra lines of code that automatically detect if this is data that has been copy-pasted from SAP's SE16 transaction. When detected, the delimiter is automatically changed to the pipe or | and the fourth line of text is used as the source for field names.
Function ImportFromUnicode(strTableName As String, strFileName As String, Optional ByVal strDelim As String = vbTab) As Boolean
Dim rs As DAO.Recordset
Dim nCurrent As Long, nFieldCount As Long, nRecordCount As Long
Dim RetVal As Variant, nCurRec As Long, dnow As Date, nCurSec As Long
Dim nTotalSeconds As Long, nSecondsLeft As Long
Dim nTotalbytes As Long, nFileLen As Long
Dim strTest As Variant
Dim strTemp As String
Dim strHeadersIn() As String
Dim strHeaders(999) As String
Const nReadAhead As Long = 30000
Dim nSizes(999) As Long, strRecords() As String, nRecords As Long, nLoaded As Long
Dim strFields() As String
Dim nHeaders As Long
Dim isSAP As Boolean
nFileLen = FileLen(strFileName)
RetVal = SysCmd(acSysCmdSetStatus, "Preparing to import " & strTableName & " from " & strFileName & "...")
RetVal = DoEvents()
'Open strFileName For Input As #1
Dim objStream, strData
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "utf-8"
objStream.Open
objStream.LoadFromFile (strFileName)
strData = objStream.ReadText()
objStream.Close
strRecords = Split(strData, vbCrLf)
strTest = strRecords(0)
If Left(strTest, 6) = "Table:" Then 'This is an SAP extract!
isSAP = True
strTest = strRecords(3) 'Fourth line has the headers!
nRecords = 4
nLoaded = 4
strDelim = "|"
Else
isSAP = False
nRecords = 1
nLoaded = 1
End If
nTotalbytes = nTotalbytes + Len(strTest) + 2 ' +2 for vbCrLf--This line prevents div by zero later...
strTest = Trim(strTest)
If Right(strTest, 1) = strDelim Then
strTest = Left(strTest, Len(strTest) - 1)
End If
strHeadersIn = Split(Trim(strTest), strDelim)
nHeaders = 0
For Each strTest In strHeadersIn
nHeaders = nHeaders + 1
strTest = Replace(Replace(strTest, " ", ""), ".", "")
strTest = Replace(Replace(strTest, " ", ""), ".", "")
If Len(Trim(strTest)) = 0 Then
strHeaders(nHeaders) = "HEADER" & Right("000" & nHeaders, 3)
Else
strHeaders(nHeaders) = Trim(strTest)
End If
For nCurrent = 1 To nHeaders - 1
If strHeaders(nHeaders) = strHeaders(nCurrent) Then
strHeaders(nHeaders) = strHeaders(nHeaders) & nHeaders
End If
Next
Next
strHeaders(0) = nHeaders
RetVal = SysCmd(acSysCmdClearStatus)
RetVal = SysCmd(acSysCmdInitMeter, "Preparing to import " & strTableName & " from " & strFileName & "...", nReadAhead)
RetVal = DoEvents()
Do While nRecords < UBound(strRecords) 'Read through the file and get the maximum sizes for fields in advance.
strTest = strRecords(nRecords)
strTest = Trim(strTest)
If Right(strTest, 1) = strDelim Then
strTest = Left(strTest, Len(strTest) - 1)
End If
If isSAP And Left(strTest, 20) = "--------------------" Then
strTest = "" 'Skip this line!
End If
If Len(strTest) > 0 Then
strFields = Split(strTest, strDelim)
nCurrent = 0
For Each strTest In strFields
nCurrent = nCurrent + 1
If Len(strTest) > nSizes(nCurrent) Then
nSizes(nCurrent) = Len(strTest)
End If
Next
End If
nRecords = nRecords + 1
Loop
If CreateTable(strTableName, strHeaders, nSizes) Then
If isSAP Then
For nCurrent = 1 To nHeaders
If Left(strHeaders(nCurrent), 8) = "HEADER00" Then
strHeaders(nCurrent) = "" 'Don't bother importing this field.
End If
Next
End If
Set rs = CurrentDb.OpenRecordset(strTableName)
nTotalSeconds = 0
Do While nLoaded < UBound(strRecords)
nCurRec = nCurRec + 1
If Second(Now()) <> nCurSec Then
nCurSec = Second(Now())
nTotalSeconds = nTotalSeconds + 1
'RetVal = DoEvents()
If nTotalSeconds > 3 Then
'nSecondsLeft = Int(((nTotalSeconds / nCurRec) * rs.RecordCount) * ((rs.RecordCount - nCurRec) / rs.RecordCount))
nSecondsLeft = Int(((nTotalSeconds / nTotalbytes) * nFileLen) * ((nFileLen - nTotalbytes) / nFileLen))
RetVal = SysCmd(acSysCmdRemoveMeter)
RetVal = SysCmd(acSysCmdInitMeter, "Importing " & strTableName & " from " & strFileName & "... " & nSecondsLeft & " seconds remaining.", nFileLen)
RetVal = SysCmd(acSysCmdUpdateMeter, nTotalbytes)
RetVal = DoEvents()
End If
End If
nLoaded = nLoaded + 1
strTest = strRecords(nLoaded)
nTotalbytes = nTotalbytes + Len(strTest) + 2 'vbCrLf
strTest = Trim(strTest)
If Right(strTest, 1) = strDelim Then
strTest = Left(strTest, Len(strTest) - 1)
End If
If isSAP And Left(strTest, 20) = "--------------------" Then
strTest = "" 'Skip this line!
End If
If Len(strTest) > 0 Then
strFields = Split(strTest, strDelim)
nCurrent = 0
rs.AddNew
For Each strTest In strFields
nCurrent = nCurrent + 1
If Len(Trim(strHeaders(nCurrent))) > 0 Then
rs.Fields(strHeaders(nCurrent)).Value = Trim(strFields(nCurrent - 1))
End If
Next
rs.Update
End If
Loop
rs.Close
End If
RetVal = SysCmd(acSysCmdRemoveMeter)
End Function
Function CreateTable(strTableName As String, strFields() As String, nSizes() As Long) As Boolean
Dim nCounter As Long
Dim dbs As DAO.Database
'Now create the database. Rename the old database if necessary.
Set dbs = CurrentDb
Dim tdf As DAO.TableDef
Dim fld1 As DAO.Field
Dim fld2 As DAO.Field
Dim fName As String
Dim fType As Integer
Dim fSize As Integer
On Error GoTo ErrorHandler
'Check for existence of TargetTable
nCounter = 0
Do While nCounter < dbs.TableDefs.Count
If dbs.TableDefs(nCounter).Name = strTableName Then
'Delete TargetTable--must start from scratch
dbs.TableDefs.Delete (strTableName)
End If
nCounter = nCounter + 1
Loop
Set tdf = dbs.CreateTableDef(strTableName)
For nCounter = 1 To Val(strFields(0))
fName = strFields(nCounter)
fType = dbText 'Never encounter type-mismatch if we always use text.
fSize = nSizes(nCounter) 'fSize = 255
Set fld1 = tdf.CreateField(fName, fType, fSize)
fld1.AllowZeroLength = True
fld1.Required = False
tdf.Fields.Append fld1
Next
'Create the table in the database
dbs.TableDefs.Append tdf
dbs.TableDefs.Refresh
CreateTable = True
Exit Function
ErrorHandler:
MsgBox "Error number " & Err.Number & ": " & Err.Description
CreateTable = False
Exit Function
End Function
