All nicely worked out now:
Function GetSelectFields(strSelectFrom As String) As Variant
Dim arr
Dim strSelect As String
Dim lStart As Long
Dim lEnd As Long
Dim i As Long
lStart = InStr(6, strSelectFrom, " ", vbBinaryCompare) + 1
lEnd = InStr(lStart, UCase(strSelectFrom), " FROM", vbBinaryCompare)
strSelect = Replace(Trim(Mid$(strSelectFrom, _
lStart, _
lEnd - lStart)), _
" ", _
"", _
1, _
-1, _
vbBinaryCompare)
'£ is one of the very few non-letter chars allowed, other one is
under-score
'---------------------------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
GetSelectFields = Replace(strSelect, ".", "£", 1, -1, vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
arr(i) = Replace(arr(i), ".", "£", 1, -1, vbBinaryCompare)
Next
GetSelectFields = arr
End If
End Function
Function MakeFieldDefs(arrFields As Variant, _
arrTypes As Variant, _
lFieldCount As Long, _
bAddTypes As Boolean) As String
Dim i As Long
Dim strTemp As String
If bAddTypes Then
If lFieldCount = 1 Then
MakeFieldDefs = "(" & arrFields & " " & arrTypes & ")"
Else
strTemp = "(" & arrFields(0) & " " & arrTypes(0) & ", "
For i = 1 To UBound(arrFields)
If i = UBound(arrFields) Then
strTemp = strTemp & arrFields(i) & " " & arrTypes(i) & ")"
Else
strTemp = strTemp & arrFields(i) & " " & arrTypes(i) & ", "
End If
Next
End If
Else
If lFieldCount = 1 Then
MakeFieldDefs = " (" & arrFields & ") "
Else
strTemp = "(" & arrFields(0) & ", "
For i = 1 To UBound(arrFields)
If i = UBound(arrFields) Then
strTemp = strTemp & arrFields(i) & ") "
Else
strTemp = strTemp & arrFields(i) & ", "
End If
Next
End If
End If
MakeFieldDefs = strTemp
End Function
Sub Test()
Dim strMDBPath As String
Dim strUN As String
Dim strPW As String
Dim strDSN As String
Dim strDBPath As String
Dim lOLDMETADATA As Long
Dim strSelectFrom As String
Dim strWhere As String
Dim strTable As String
Dim arrTypes As Variant
strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "********"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
strSelectFrom = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) "
strWhere = " WHERE E.READ_CODE = 'G3...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"
arrTypes = Array("CHAR", "CHAR")
IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, strSelectFrom, strWhere, _
strTable, _
arrTypes, _
2
End Sub
Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSelectFrom As String, _
strWhere As String, _
strTable As String, _
arrTypes As Variant, _
lFieldCount As Long)
Dim db As DAO.Database
Dim strConnect As String
Dim arrFields
Dim strFieldDefs As String
arrFields = GetSelectFields(strSelectFrom)
On Error Resume Next
Kill strMDBPath
On Error GoTo 0
strConnect = "ODBC;" & _
"DSN=" & strDSN & ";" & _
"UID=" & strUN & ";" & _
"PWD=" & strPW & ";" & _
"DB=" & strDBPath & ";" & _
"OLDMETADATA=" & lOLDMETADATA & ";"
Set db = DBEngine.CreateDatabase(strMDBPath, dbLangGeneral)
With db
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount, True)
.Execute "CREATE TABLE " & _
strTable & _
strFieldDefs, _
dbFailOnError
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount, False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "]" & _
strWhere, _
dbFailOnError
.Close
End With
Set db = Nothing
End Sub
RBS
Dirk Goldgar said:
RB Smissaert said:
OK, thanks, then it must be my connection string at fault.
This is my code:
Sub test()
Dim db As DAO.Database
Dim strConnect As String
On Error Resume Next
Kill "C:\test.mdb"
On Error GoTo 0
strConnect = [deleted by Dirk]"
Set db = DBEngine.CreateDatabase("C:\test.mdb", dbLangGeneral)
With db
.Execute "CREATE TABLE tblFoo (Field1 CHAR, Field2 CHAR)", _
dbFailOnError
.Execute "INSERT INTO tblFoo (Field1, Field2) " & _
"SELECT STAFF_ID, SURNAME FROM STAFF IN """" [" & _
strConnect & _
"]", _
dbFailOnError
.Close
End With
Set db = Nothing
End Sub
And this is the error message:
Runtime error 3321, No database specified in connection string or IN
clause. So, yes that must be my faulty connection string.
Will get the full ODBC string that includes the db path.
That's probably not necessary. But you need to specify that it's an
ODBC connection:
strConnect = "ODBC;DSN=System 6000;UID=xxxxxxx;PWD=yyyyyyy"
--
Dirk Goldgar, MS Access MVP
www.datagnostics.com
(please reply to the newsgroup)
