J
jherritt0628
Here is the problem that I am having with an Excel spreadsheet
application – While attempting to import text files into an
Access .MDB database through the procedure I have listed below:
This is the calling function:
Sub AddFilesToDatabase()
' --- Asks for files to load and for name of and existing
' or new database into which to load them
' --- Create a new database if necessary, then creates a table
' in that database for each file chosen by the user,
' a different routine is called for this depending on
' whether the file is a data file or a plate map file.
' Lets user choose multiple plate map and well data files,
parsed them and stores
' them in the data base.
' ----------------------------------------------------------
Dim i As Integer, irow As Integer, iSize As Integer
Dim sType As String, sPlateName As String
Dim MsgString As String, DBTableName As String
On Error GoTo ErrDB
With ActiveWorkbook.Sheets("Data Sources")
If .Range("DBName") = "" Then
' sDatabaseName = InputBox("Enter a name for the database
that will be created to hold your plate map files and data files.")
' If sDatabaseName = "" Then Exit Sub
' .Range("DBName") = sDatabaseName
' --- Set up the database path and name dialog box
With frmDBPath.CommonDialog1
.MaxFileSize = 10000
.Filter = "Explorer Data File |*.mdb"
.Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer Or
cdlOFNLongNames Or cdlOFNHideReadOnly
.filename = " "
If sLastDir <> "" Then .InitDir = sLastDir
.ShowOpen
sDatabaseLocation = .filename
sDatabaseName = .FileTitle
End With
' sDatabaseLocation = ActiveWorkbook.Path & "\" &
sDatabaseName & ".mdb"
If sDatabaseName = "" Or InStr(Trim(sDatabaseName), ".") =
0 Then Exit Sub
.Range("DBName") = Left(sDatabaseName, Len(sDatabaseName)
- 4)
.Range("DBLocation") = sDatabaseLocation
Call CreateDatabase(sDatabaseLocation, dbAtto) ' Create
the new database
Else
sDatabaseName = .Range("DBName") ' Reference the existing
database
sDatabaseLocation = .Range("DBLocation")
End If
End With
' --- Set up the file dialog box
With frmShowDirsFiles.CommonDialog1
.MaxFileSize = 10000
.Filter = "Text |*.txt"
.Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer Or
cdlOFNLongNames Or cdlOFNHideReadOnly
.filename = " "
If sLastDir <> "" Then .InitDir = sLastDir
.ShowOpen
sAllFilesForAnalysis = .filename
If sAllFilesForAnalysis = " " Then Exit Sub
sFilesNames = .FileTitle
End With
' --- Open the database
Set dbAtto = dbengine.OpenDatabase(sDatabaseLocation)
On Error GoTo 0 'disable error handling at this level
Call RecordFilesToLoad(sAllFilesForAnalysis)
' Call IDDataFiles
' --- Parse each file and load it as a table into the database
MsgString = "The following files have been added to the Excel Data
File " & sDatabaseName & ":"
For i = 1 To UBound(UserFiles)
bTableOK = True ' This will get set to false if any table
fails to load
sType = UserFiles(i).sFileType
DBTableName =
SanitizeString(RemoveSpaces(UserFiles(i).sFileSheetName))
If Not
(StatusTableCheck(SanitizeString(RemoveSpaces(UserFiles(i).sFileSheetName))))
Then
DBTableName = SanitizeString(RemoveSpaces(InputBox("A
Table with the name " &
SanitizeString(RemoveSpaces(UserFiles(i).sFileSheetName)) & " already
exists in the Explorer Data File. Enter a different name for this new
file.")))
End If
Select Case sType
Case "Plate Map"
iWellCount = 0
Call StorePlateMapFileInDB(i, DBTableName)
Case Else
iWellCount = 0
Call StoreDataFileInDB(i, DBTableName)
Select Case iWellCountMax
Case Is <= 96
sPlateName = "Default_96_Well_Plate_Map"
iSize = 96
Case Is > 96, Is <= 384
sPlateName = "Default_384_Well_Plate_Map"
iSize = 384
End Select
' --- Link this data file to one of the default plate maps
Call LinkTableUpdate(sPlateName, DBTableName)
End Select
' --- Update the Status table to show these new files
If bTableOK Then
Call StatusTableUpdate(UserFiles(i).sFilePath,
DBTableName, UserFiles(i).sFileType, False, iWellCount)
MsgString = MsgString & Chr(13) &
UserFiles(i).sFileSheetName
irow = FindNextFreeDataSourceRow("Data Sources",
"DataFileDirectory")
With Worksheets("Data Sources").Range("DataFileDirectory")
.Cells(irow, 1) = UserFiles(i).sFilePath
.Cells(irow, 2) = DBTableName
.Cells(irow, 3) = UserFiles(i).sFileType
.Cells(irow, 4) = "FALSE"
End With
End If
Next i
MsgBox MsgString
dbAtto.Close
Set dbAtto = Nothing
Exit Sub
ErrDB:
If Err.Number = 3204 Then
MsgBox "The Explorer Data File " & sDatabaseName & " already
exists in the directory you have chosen. You may add additional data
files to it now."
Else
MsgBox "BD Image Data Explorer could not find the Explorer
Data File at " & sDatabaseLocation & ". Replace it at that location,
or type a new location for it into the Data Sources worksheet."
End If
End Sub
Function AddUnderDash(sName As String) As String
' --- Substitutes a underdash for each space in a string
' Use this to make table names with spaces work
Dim i As Integer
Dim sTemp As String
sTemp = sName
i = InStr(sTemp, " ")
Do Until i = 0
sTemp = Left(sTemp, i - 1) & "_" & Right(sTemp, Len(sTemp) - i)
i = InStr(sTemp, " ")
Loop
AddUnderDash = sTemp
End Function
Function AddUnderDash(sName As String) As String
' --- Substitutes a underdash for each space in a string
' Use this to make table names with spaces work
Dim i As Integer
Dim sTemp As String
sTemp = sName
i = InStr(sTemp, " ")
Do Until i = 0
sTemp = Left(sTemp, i - 1) & "_" & Right(sTemp, Len(sTemp) - i)
i = InStr(sTemp, " ")
Loop
AddUnderDash = sTemp
End Function
Sub OpenNRecords(SQLString As String, N As Integer)
' --- Opens the table sNameOfTable in the current database
' executes the SQLString
' and reads in N records into recset.
' cn and recset are public variables
' -----------------------------------------------------------
The template spreadsheet closes down when it reaches the highlighted
code:
If sDatabaseLocation <> "" Then
connstring = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " &
sDatabaseLocation & ";Persist Security Info=False"
Set cn = New ADODB.Connection
cn.Open (connstring)
Set RecSet = New ADODB.Recordset
With RecSet
.ActiveConnection = cn
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.MaxRecords = N
.Open Source:=SQLString, LockType:=adLockOptimistic
End With
End If
End Sub
(NOTE: There is no error code generated. Is this an ODBC driver
problem?)
If anyone has any ideas how to solve this issue. I would appreciate
hearing from you. Thanks!
John Herritt
application – While attempting to import text files into an
Access .MDB database through the procedure I have listed below:
This is the calling function:
Sub AddFilesToDatabase()
' --- Asks for files to load and for name of and existing
' or new database into which to load them
' --- Create a new database if necessary, then creates a table
' in that database for each file chosen by the user,
' a different routine is called for this depending on
' whether the file is a data file or a plate map file.
' Lets user choose multiple plate map and well data files,
parsed them and stores
' them in the data base.
' ----------------------------------------------------------
Dim i As Integer, irow As Integer, iSize As Integer
Dim sType As String, sPlateName As String
Dim MsgString As String, DBTableName As String
On Error GoTo ErrDB
With ActiveWorkbook.Sheets("Data Sources")
If .Range("DBName") = "" Then
' sDatabaseName = InputBox("Enter a name for the database
that will be created to hold your plate map files and data files.")
' If sDatabaseName = "" Then Exit Sub
' .Range("DBName") = sDatabaseName
' --- Set up the database path and name dialog box
With frmDBPath.CommonDialog1
.MaxFileSize = 10000
.Filter = "Explorer Data File |*.mdb"
.Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer Or
cdlOFNLongNames Or cdlOFNHideReadOnly
.filename = " "
If sLastDir <> "" Then .InitDir = sLastDir
.ShowOpen
sDatabaseLocation = .filename
sDatabaseName = .FileTitle
End With
' sDatabaseLocation = ActiveWorkbook.Path & "\" &
sDatabaseName & ".mdb"
If sDatabaseName = "" Or InStr(Trim(sDatabaseName), ".") =
0 Then Exit Sub
.Range("DBName") = Left(sDatabaseName, Len(sDatabaseName)
- 4)
.Range("DBLocation") = sDatabaseLocation
Call CreateDatabase(sDatabaseLocation, dbAtto) ' Create
the new database
Else
sDatabaseName = .Range("DBName") ' Reference the existing
database
sDatabaseLocation = .Range("DBLocation")
End If
End With
' --- Set up the file dialog box
With frmShowDirsFiles.CommonDialog1
.MaxFileSize = 10000
.Filter = "Text |*.txt"
.Flags = cdlOFNAllowMultiselect Or cdlOFNExplorer Or
cdlOFNLongNames Or cdlOFNHideReadOnly
.filename = " "
If sLastDir <> "" Then .InitDir = sLastDir
.ShowOpen
sAllFilesForAnalysis = .filename
If sAllFilesForAnalysis = " " Then Exit Sub
sFilesNames = .FileTitle
End With
' --- Open the database
Set dbAtto = dbengine.OpenDatabase(sDatabaseLocation)
On Error GoTo 0 'disable error handling at this level
Call RecordFilesToLoad(sAllFilesForAnalysis)
' Call IDDataFiles
' --- Parse each file and load it as a table into the database
MsgString = "The following files have been added to the Excel Data
File " & sDatabaseName & ":"
For i = 1 To UBound(UserFiles)
bTableOK = True ' This will get set to false if any table
fails to load
sType = UserFiles(i).sFileType
DBTableName =
SanitizeString(RemoveSpaces(UserFiles(i).sFileSheetName))
If Not
(StatusTableCheck(SanitizeString(RemoveSpaces(UserFiles(i).sFileSheetName))))
Then
DBTableName = SanitizeString(RemoveSpaces(InputBox("A
Table with the name " &
SanitizeString(RemoveSpaces(UserFiles(i).sFileSheetName)) & " already
exists in the Explorer Data File. Enter a different name for this new
file.")))
End If
Select Case sType
Case "Plate Map"
iWellCount = 0
Call StorePlateMapFileInDB(i, DBTableName)
Case Else
iWellCount = 0
Call StoreDataFileInDB(i, DBTableName)
Select Case iWellCountMax
Case Is <= 96
sPlateName = "Default_96_Well_Plate_Map"
iSize = 96
Case Is > 96, Is <= 384
sPlateName = "Default_384_Well_Plate_Map"
iSize = 384
End Select
' --- Link this data file to one of the default plate maps
Call LinkTableUpdate(sPlateName, DBTableName)
End Select
' --- Update the Status table to show these new files
If bTableOK Then
Call StatusTableUpdate(UserFiles(i).sFilePath,
DBTableName, UserFiles(i).sFileType, False, iWellCount)
MsgString = MsgString & Chr(13) &
UserFiles(i).sFileSheetName
irow = FindNextFreeDataSourceRow("Data Sources",
"DataFileDirectory")
With Worksheets("Data Sources").Range("DataFileDirectory")
.Cells(irow, 1) = UserFiles(i).sFilePath
.Cells(irow, 2) = DBTableName
.Cells(irow, 3) = UserFiles(i).sFileType
.Cells(irow, 4) = "FALSE"
End With
End If
Next i
MsgBox MsgString
dbAtto.Close
Set dbAtto = Nothing
Exit Sub
ErrDB:
If Err.Number = 3204 Then
MsgBox "The Explorer Data File " & sDatabaseName & " already
exists in the directory you have chosen. You may add additional data
files to it now."
Else
MsgBox "BD Image Data Explorer could not find the Explorer
Data File at " & sDatabaseLocation & ". Replace it at that location,
or type a new location for it into the Data Sources worksheet."
End If
End Sub
Function AddUnderDash(sName As String) As String
' --- Substitutes a underdash for each space in a string
' Use this to make table names with spaces work
Dim i As Integer
Dim sTemp As String
sTemp = sName
i = InStr(sTemp, " ")
Do Until i = 0
sTemp = Left(sTemp, i - 1) & "_" & Right(sTemp, Len(sTemp) - i)
i = InStr(sTemp, " ")
Loop
AddUnderDash = sTemp
End Function
Function AddUnderDash(sName As String) As String
' --- Substitutes a underdash for each space in a string
' Use this to make table names with spaces work
Dim i As Integer
Dim sTemp As String
sTemp = sName
i = InStr(sTemp, " ")
Do Until i = 0
sTemp = Left(sTemp, i - 1) & "_" & Right(sTemp, Len(sTemp) - i)
i = InStr(sTemp, " ")
Loop
AddUnderDash = sTemp
End Function
Sub OpenNRecords(SQLString As String, N As Integer)
' --- Opens the table sNameOfTable in the current database
' executes the SQLString
' and reads in N records into recset.
' cn and recset are public variables
' -----------------------------------------------------------
The template spreadsheet closes down when it reaches the highlighted
code:
If sDatabaseLocation <> "" Then
connstring = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source= " &
sDatabaseLocation & ";Persist Security Info=False"
Set cn = New ADODB.Connection
cn.Open (connstring)
Set RecSet = New ADODB.Recordset
With RecSet
.ActiveConnection = cn
.CursorLocation = adUseClient
.CursorType = adOpenDynamic
.MaxRecords = N
.Open Source:=SQLString, LockType:=adLockOptimistic
End With
End If
End Sub
(NOTE: There is no error code generated. Is this an ODBC driver
problem?)
If anyone has any ideas how to solve this issue. I would appreciate
hearing from you. Thanks!
John Herritt