Interbase data to Access

RB Smissaert · May 20, 2006

Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount, False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

Pieter Wijnen · May 20, 2006

Maybe it's me but I've always used
SELECT ... FROM... IN 'Path to external Database/Connect info'
WHERE ... etc
ie ' instead of "

Also try aliasing the Count (shouldn't matter but you never know)
ie COUNT(E.ENTRY_ID) AS CNT (why not Count(*) btw)

HTH

Pieter

PS I'll try it later today with ODBC connect & see what (if anything) I can
figure out

RB Smissaert said:
Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount, False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

Dirk Goldgar said:

I see you've been very busy. Nice work! It's a pleasure to work with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

RB Smissaert · May 20, 2006

Did you mean putting the DB path first in the select string?
Tried that, no difference.

Also tried with aliasing the count, again no difference.

RBS

Pieter Wijnen said:
Maybe it's me but I've always used
SELECT ... FROM... IN 'Path to external Database/Connect info'
WHERE ... etc
ie ' instead of "

Also try aliasing the Count (shouldn't matter but you never know)
ie COUNT(E.ENTRY_ID) AS CNT (why not Count(*) btw)

HTH

Pieter

PS I'll try it later today with ODBC connect & see what (if anything) I
can figure out

RB Smissaert said:

Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount,
False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

Dirk Goldgar said:

All nicely worked out now

I see you've been very busy. Nice work! It's a pleasure to work with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

Click to expand...

RB Smissaert · May 20, 2006

The trouble is caused by the ORDER BY clause.
Leaving it off makes it work, but haven't found a way
yet to order.

RBS

Pieter Wijnen said:
Maybe it's me but I've always used
SELECT ... FROM... IN 'Path to external Database/Connect info'
WHERE ... etc
ie ' instead of "

Also try aliasing the Count (shouldn't matter but you never know)
ie COUNT(E.ENTRY_ID) AS CNT (why not Count(*) btw)

HTH

Pieter

PS I'll try it later today with ODBC connect & see what (if anything) I
can figure out

RB Smissaert said:

Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount,
False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

Dirk Goldgar said:

All nicely worked out now

I see you've been very busy. Nice work! It's a pleasure to work with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

Click to expand...

RB Smissaert · May 20, 2006

I think it simply is that you can't combine an INSERT with an ORDER BY.
Will have to sort with a second SQL or just directly in the Access table.
What would normally be faster?

RBS

RB Smissaert said:
The trouble is caused by the ORDER BY clause.
Leaving it off makes it work, but haven't found a way
yet to order.

RBS

Pieter Wijnen said:

Maybe it's me but I've always used
SELECT ... FROM... IN 'Path to external Database/Connect info'
WHERE ... etc
ie ' instead of "

Also try aliasing the Count (shouldn't matter but you never know)
ie COUNT(E.ENTRY_ID) AS CNT (why not Count(*) btw)

HTH

Pieter

PS I'll try it later today with ODBC connect & see what (if anything) I
can figure out

RB Smissaert said:

Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount,
False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1,
vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

All nicely worked out now

I see you've been very busy. Nice work! It's a pleasure to work with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

Click to expand...

Douglas J. Steele · May 20, 2006

There's no reason to order rows when you're inserting them into a table.
Regardless of what order they were inserted in, you cannot guarantee that's
the order in which they'll be returned.

--
Doug Steele, Microsoft Access MVP

(no private e-mails, please)

RB Smissaert said:
I think it simply is that you can't combine an INSERT with an ORDER BY.
Will have to sort with a second SQL or just directly in the Access table.
What would normally be faster?

RBS

RB Smissaert said:

The trouble is caused by the ORDER BY clause.
Leaving it off makes it work, but haven't found a way
yet to order.

RBS

Pieter Wijnen said:

Maybe it's me but I've always used
SELECT ... FROM... IN 'Path to external Database/Connect info'
WHERE ... etc
ie ' instead of "

Also try aliasing the Count (shouldn't matter but you never know)
ie COUNT(E.ENTRY_ID) AS CNT (why not Count(*) btw)

HTH

Pieter

PS I'll try it later today with ODBC connect & see what (if anything) I
can figure out

Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount,
False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1,
vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

All nicely worked out now

I see you've been very busy. Nice work! It's a pleasure to work with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

Click to expand...

RB Smissaert · May 20, 2006

Yes, can see that now.
How would I achieve that if the user opens the .mdb file
and the table the table appears sorted on a field I specified?
It may have to be a descending sort, if that makes a difference.

RBS

Douglas J. Steele said:
There's no reason to order rows when you're inserting them into a table.
Regardless of what order they were inserted in, you cannot guarantee
that's the order in which they'll be returned.

--
Doug Steele, Microsoft Access MVP

(no private e-mails, please)

RB Smissaert said:

I think it simply is that you can't combine an INSERT with an ORDER BY.
Will have to sort with a second SQL or just directly in the Access table.
What would normally be faster?

RBS

RB Smissaert said:

The trouble is caused by the ORDER BY clause.
Leaving it off makes it work, but haven't found a way
yet to order.

RBS

Maybe it's me but I've always used
SELECT ... FROM... IN 'Path to external Database/Connect info'
WHERE ... etc
ie ' instead of "

Also try aliasing the Count (shouldn't matter but you never know)
ie COUNT(E.ENTRY_ID) AS CNT (why not Count(*) btw)

HTH

Pieter

PS I'll try it later today with ODBC connect & see what (if anything) I
can figure out

Have worked this out a bit further, but not been able yet
to make it work with GROUP BY constructions. Could it work with
that? The problem might be that I still don't understand what exactly
is going on at:
" IN """"

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"
'strSQL = "SELECT E.READ_CODE, E.TERM_TEXT " & _
"FROM ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE E.READ_CODE = 'G2...' AND " & _
"NOT P.MAIN_REG_TYPE = 1"

'--------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'--------------------------------------
strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"
'arrTypes = Array("CHAR", "CHAR")
arrTypes = Array("CHAR", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant)

Dim db As DAO.Database
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFieldDefs As String

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom)
lFieldCount = CountChar(",", strSelectFrom) + 1

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

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount,
False)
.Execute "INSERT INTO " & _
strTable & _
strFieldDefs & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lWherePos As Long
Dim arr(1 To 2) As String

lWherePos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lWherePos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lWherePos - 1))
arr(2) = Trim(Mid$(strSQL, lWherePos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String) As Variant

Dim arr
Dim strSelect As String
Dim strTemp 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 as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
GetSelectFields = Replace(strTemp, ".", "_", 1, -1,
vbBinaryCompare)
Else
arr = Split(strSelect, ",")
For i = 0 To UBound(arr)
strTemp = Replace(arr(i), "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)
arr(i) = Replace(strTemp, ".", "_", 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

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

RBS

All nicely worked out now

I see you've been very busy. Nice work! It's a pleasure to work
with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

Click to expand...

RB Smissaert · May 20, 2006

Have worked this still a bit further out.
One drawback I can see from working with arrays is that
you have to specify the field datatypes, although it seems Access can do
that
itself quite OK from the data.
Is there a way to do this without setting the datatype for the fields in the
query?

Option Explicit

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"

'seems can't do DISTINCT with an INSERT
'--------------------------------------
'strSQL = "SELECT " & _
"E.PATIENT_ID, E.READ_CODE, E.TERM_TEXT " & _
"FROM " & _
"ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE " & _
"E.READ_CODE = 'G58..' AND " & _
"P.MAIN_REG_TYPE = 1"

'arrTypes = Array("LONG", "CHAR", "CHAR")

'----------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'reason most likely:
'can't combine an INSERT with an ORDER BY
'best just to take it off
'----------------------------------------
'strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) AS CNT FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"

'arrTypes = Array("CHAR", "LONG")

strSQL = "SELECT S.ROLE_TYPE, COUNT(S.STAFF_ID) FROM STAFF S " & _
"GROUP BY S.ROLE_TYPE"

arrTypes = Array("LONG", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes, _
False, _
False

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant, _
bAutoTypes As Boolean, _
bNewFile As Boolean)

Dim db As DAO.Database
Dim oTableDef As DAO.TableDef
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFields As String
Dim strFieldDefs As String
Dim lOrderByPos As Long

'ORDER BY won't work with INSERT, so take it off here
'----------------------------------------------------
lOrderByPos = InStr(1, UCase(strSQL), "ORDER BY", vbBinaryCompare)
If lOrderByPos > 0 Then
strSQL = Left$(strSQL, lOrderByPos - 1)
End If

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom, True)
lFieldCount = CountChar(",", strSelectFrom) + 1

If bNewFile Then
On Error Resume Next
Kill strMDBPath
On Error GoTo 0
Set db = DBEngine.CreateDatabase(strMDBPath, dbLangGeneral)
Else
If bFileExists(strMDBPath) Then
Set db = DBEngine.OpenDatabase(strMDBPath)
Else
Set db = DBEngine.CreateDatabase(strMDBPath, dbLangGeneral)
End If
End If

'order doesn't seem to matter here, except ODBC has to be first
'--------------------------------------------------------------
strConnect = "ODBC;" & _
"DB=" & strDBPath & ";" & _
"DSN=" & strDSN & ";" & _
"UID=" & strUN & ";" & _
"PWD=" & strPW & ";" & _
"OLDMETADATA=" & lOLDMETADATA & ";"

With db

'avoiding specifying an existing table
'-------------------------------------
If bNewFile = False Then
AGAIN:
For Each oTableDef In .TableDefs
If oTableDef.Name = strTable Then
strTable = IncreaseLastNumberInString(strTable)
GoTo AGAIN
End If
Next
End If

'field names + data types, if bAllCHAR = True then arrTypes will be
ignored
'and the data types will determined from the field names
'--------------------------------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount, True,
bAutoTypes)

.Execute "CREATE TABLE " & _
strTable & _
strFieldDefs, _
dbFailOnError

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------

'field names only
'----------------
strFields = MakeFieldDefs(arrFields, arrTypes, lFieldCount, False,
False)
.Execute "INSERT INTO " & _
strTable & _
strFields & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lSplitPos As Long
Dim arr(1 To 2) As String

lSplitPos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lSplitPos = 0 Then
lSplitPos = InStr(1, UCase(strSQL), "GROUP BY", vbBinaryCompare)
End If

If lSplitPos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lSplitPos - 1))
arr(2) = Trim(Mid$(strSQL, lSplitPos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String, bGetAlias As Boolean) As
Variant

Dim arr
Dim strSelect As String
Dim strTemp As String
Dim lStart As Long
Dim lEnd As Long
Dim lSpacePos As Long
Dim lASPos As Long
Dim i As Long

lStart = InStr(6, strSelectFrom, " ", vbBinaryCompare) + 1
lEnd = InStr(lStart, UCase(strSelectFrom), " FROM", vbBinaryCompare)
strSelect = Trim(Mid$(strSelectFrom, _
lStart, _
lEnd - lStart))

'£ is one of the very few non-letter chars allowed as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)

lSpacePos = InStr(1, strTemp, " ", vbBinaryCompare)

If lSpacePos > 0 Then
If bGetAlias Then
'to get the ALIAS off the SELECT FIELD
'-------------------------------------
lASPos = InStr(1, UCase(strTemp), " AS ", vbBinaryCompare)
If lASPos = 0 Then
strTemp = Left$(strTemp, lSpacePos - 1)
Else
strTemp = Trim(Mid$(strTemp, lASPos + 4))
End If
End If
Else
strTemp = Left$(strTemp, lSpacePos - 1)
End If
GetSelectFields = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Else

arr = Split(strSelect, ",")

For i = 0 To UBound(arr)
strTemp = Trim(arr(i))
strTemp = Replace(strTemp, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)

lSpacePos = InStr(1, strTemp, " ", vbBinaryCompare)

If lSpacePos > 0 Then
If bGetAlias Then
'to get the ALIAS off the SELECT FIELD
'-------------------------------------
lASPos = InStr(1, UCase(strTemp), " AS ", vbBinaryCompare)
If lASPos = 0 Then
strTemp = Left$(strTemp, lSpacePos - 1)
Else
strTemp = Trim(Mid$(strTemp, lASPos + 4))
End If
Else
strTemp = Left$(strTemp, lSpacePos - 1)
End If
End If
arr(i) = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Next
GetSelectFields = arr
End If

End Function

Function MakeFieldDefs(arrFields As Variant, _
arrTypes As Variant, _
lFieldCount As Long, _
bAddTypes As Boolean, _
bAutoTypes As Boolean) As String

'will attempt to set the data type from the field name:
'ending with _ID: LONG
'with DATE: LONG
'with COUNT: LONG
'with VALUE: DOUBLE
'else: CHAR
'------------------------------------------------------

Dim i As Long
Dim strTemp As String

If bAddTypes Then
If bAutoTypes Then
If lFieldCount = 1 Then
If Right$(UCase(arrFields), 3) = "_ID" Or _
InStr(1, UCase(arrFields), "DATE", vbBinaryCompare) > 0 Or _
InStr(1, UCase(arrFields), "COUNT", vbBinaryCompare) > 0 Or _
InStr(1, UCase(arrFields), "_BY", vbBinaryCompare) > 0 Or _
InStr(1, UCase(arrFields), "_GP", vbBinaryCompare) > 0 Then
MakeFieldDefs = "(" & arrFields & " " & "LONG" & ")"
Else
If InStr(1, UCase(arrFields), "VALUE", vbBinaryCompare) = 0
Then
MakeFieldDefs = "(" & arrFields & " " & "CHAR" & ")"
Else
MakeFieldDefs = "(" & arrFields & " " & "DOUBLE" & ")"
End If
End If
Else 'If lFieldCount = 1
If Right$(UCase(arrFields(0)), 3) = "_ID" Or _
InStr(1, UCase(arrFields(0)), "DATE", vbBinaryCompare) > 0 Or
_
InStr(1, UCase(arrFields(0)), "COUNT", vbBinaryCompare) > 0
Or _
InStr(1, UCase(arrFields(0)), "_BY", vbBinaryCompare) > 0 Or
_
InStr(1, UCase(arrFields(0)), "_GP", vbBinaryCompare) > 0
Then
strTemp = "(" & arrFields(0) & " " & "LONG" & ", "
Else
If InStr(1, UCase(arrFields(0)), "VALUE", vbBinaryCompare) =
0 Then
strTemp = "(" & arrFields(0) & " " & "CHAR" & ", "
Else
strTemp = "(" & arrFields(0) & " " & "DOUBLE" & ", "
End If
End If
For i = 1 To UBound(arrFields)
If i = UBound(arrFields) Then
If Right$(UCase(arrFields(i)), 3) = "_ID" Or _
InStr(1, UCase(arrFields(i)), "DATE", vbBinaryCompare)

0 Or _

InStr(1, UCase(arrFields(i)), "COUNT", vbBinaryCompare)

0 Or _

InStr(1, UCase(arrFields(i)), "_BY", vbBinaryCompare) >
0 Or _
InStr(1, UCase(arrFields(i)), "_GP", vbBinaryCompare) >
0 Then
strTemp = strTemp & arrFields(i) & " " & "LONG" & ")"
Else
If InStr(1, UCase(arrFields(i)), "VALUE",
vbBinaryCompare) = 0 Then
strTemp = strTemp & arrFields(i) & " " & "CHAR" &
")"
Else
strTemp = strTemp & arrFields(i) & " " & "DOUBLE" &
")"
End If
End If
Else
If Right$(UCase(arrFields(i)), 3) = "_ID" Or _
InStr(1, UCase(arrFields(i)), "DATE", vbBinaryCompare)

0 Or _

InStr(1, UCase(arrFields(i)), "COUNT", vbBinaryCompare)

0 Or _

InStr(1, UCase(arrFields(i)), "_BY", vbBinaryCompare) >
0 Or _
InStr(1, UCase(arrFields(i)), "_GP", vbBinaryCompare) >
0 Then
strTemp = strTemp & arrFields(i) & " " & "LONG" & ", "
Else
If InStr(1, UCase(arrFields(i)), "VALUE",
vbBinaryCompare) = 0 Then
strTemp = strTemp & arrFields(i) & " " & "CHAR" & ",
"
Else
strTemp = strTemp & arrFields(i) & " " & "DOUBLE" &
", "
End If
End If
End If
Next
End If 'If lFieldCount = 1
Else 'If bAllCHAR
If lFieldCount = 1 Then
MakeFieldDefs = "(" & arrFields & " " & arrTypes & ")"
Else 'lFieldCount = 1
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 'lFieldCount = 1
End If 'If bAllCHAR
Else 'If bAddTypes
If lFieldCount = 1 Then
MakeFieldDefs = " (" & arrFields & ") "
Else 'If lFieldCount = 1
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 'If lFieldCount = 1
End If 'If bAddTypes

MakeFieldDefs = strTemp

End Function

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

Function IncreaseLastNumberInString(ByVal strString As String) As String

Dim i As Long
Dim btArray() As Byte
Dim lLast As Long
Dim lLastLetterPos As Long

If Asc(Right$(strString, 1)) < 48 Or _
Asc(Right$(strString, 1)) > 57 Then
IncreaseLastNumberInString = strString & "2"
Exit Function
End If

btArray = strString
lLast = UBound(btArray)

For i = lLast To 0 Step -2
If btArray(i) < 48 Or btArray(i) > 57 Then
lLastLetterPos = i \ 2
Exit For
End If
Next

IncreaseLastNumberInString = Left$(strString, lLastLetterPos) & _
Val(Mid$(strString, _
lLastLetterPos + 1)) + 1

End Function

Function bFileExists(ByVal sFile As String) As Boolean

Dim lAttr As Long

On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0

End Function

RBS

RB Smissaert · May 20, 2006

Meant to say:
One drawback I can see from working with Access tables is etc.

RBS

RB Smissaert said:
Have worked this still a bit further out.
One drawback I can see from working with arrays is that
you have to specify the field datatypes, although it seems Access can do
that
itself quite OK from the data.
Is there a way to do this without setting the datatype for the fields in
the query?

Option Explicit

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 strSQL As String
Dim strTable As String
Dim arrTypes As Variant

strMDBPath = "C:\test.mdb"
strUN = "sysdba"
strPW = "torexkey"
strDSN = "System 6000"
strDBPath = "C:\Torex\Synergy\Meddata\S6000\db\s6.gdb"
lOLDMETADATA = 1
strTable = "TestTable"

'seems can't do DISTINCT with an INSERT
'--------------------------------------
'strSQL = "SELECT " & _
"E.PATIENT_ID, E.READ_CODE, E.TERM_TEXT " & _
"FROM " & _
"ENTRY E INNER JOIN PATIENT P ON " & _
"(E.PATIENT_ID = P.PATIENT_ID) " & _
"WHERE " & _
"E.READ_CODE = 'G58..' AND " & _
"P.MAIN_REG_TYPE = 1"

'arrTypes = Array("LONG", "CHAR", "CHAR")

'----------------------------------------
'this one doesn't work, will get:
'ODBC - call failed. (Error 3146)
'reason most likely:
'can't combine an INSERT with an ORDER BY
'best just to take it off
'----------------------------------------
'strSQL = "SELECT E.READ_CODE, COUNT(E.ENTRY_ID) AS CNT FROM " & _
"ENTRY E WHERE E.READ_CODE LIKE 'G%' " & _
"GROUP BY E.READ_CODE " & _
"ORDER BY 2 DESC"

'arrTypes = Array("CHAR", "LONG")

strSQL = "SELECT S.ROLE_TYPE, COUNT(S.STAFF_ID) FROM STAFF S " & _
"GROUP BY S.ROLE_TYPE"

arrTypes = Array("LONG", "LONG")

IB2Access strMDBPath, _
strUN, _
strPW, _
strDSN, _
strDBPath, _
lOLDMETADATA, _
strSQL, _
strTable, _
arrTypes, _
False, _
False

End Sub

Sub IB2Access(strMDBPath As String, _
strUN As String, _
strPW As String, _
strDSN As String, _
strDBPath As String, _
lOLDMETADATA As Long, _
strSQL As String, _
strTable As String, _
arrTypes As Variant, _
bAutoTypes As Boolean, _
bNewFile As Boolean)

Dim db As DAO.Database
Dim oTableDef As DAO.TableDef
Dim strConnect As String
Dim arr
Dim strSelectFrom As String
Dim lFieldCount As Long
'could start at GROUP BY or ORDER BY
'if there is no WHERE clause
'that is if this could work
'-----------------------------------
Dim strWhere As String
Dim arrFields
Dim strFields As String
Dim strFieldDefs As String
Dim lOrderByPos As Long

'ORDER BY won't work with INSERT, so take it off here
'----------------------------------------------------
lOrderByPos = InStr(1, UCase(strSQL), "ORDER BY", vbBinaryCompare)
If lOrderByPos > 0 Then
strSQL = Left$(strSQL, lOrderByPos - 1)
End If

arr = SplitSQLOnWhere(strSQL)
strSelectFrom = arr(1)
strWhere = arr(2)
arrFields = GetSelectFields(strSelectFrom, True)
lFieldCount = CountChar(",", strSelectFrom) + 1

If bNewFile Then
On Error Resume Next
Kill strMDBPath
On Error GoTo 0
Set db = DBEngine.CreateDatabase(strMDBPath, dbLangGeneral)
Else
If bFileExists(strMDBPath) Then
Set db = DBEngine.OpenDatabase(strMDBPath)
Else
Set db = DBEngine.CreateDatabase(strMDBPath, dbLangGeneral)
End If
End If

'order doesn't seem to matter here, except ODBC has to be first
'--------------------------------------------------------------
strConnect = "ODBC;" & _
"DB=" & strDBPath & ";" & _
"DSN=" & strDSN & ";" & _
"UID=" & strUN & ";" & _
"PWD=" & strPW & ";" & _
"OLDMETADATA=" & lOLDMETADATA & ";"

With db

'avoiding specifying an existing table
'-------------------------------------
If bNewFile = False Then
AGAIN:
For Each oTableDef In .TableDefs
If oTableDef.Name = strTable Then
strTable = IncreaseLastNumberInString(strTable)
GoTo AGAIN
End If
Next
End If

'field names + data types, if bAllCHAR = True then arrTypes will be
ignored
'and the data types will determined from the field names

'--------------------------------------------------------------------------
strFieldDefs = MakeFieldDefs(arrFields, arrTypes, lFieldCount, True,
bAutoTypes)

.Execute "CREATE TABLE " & _
strTable & _
strFieldDefs, _
dbFailOnError

'not figured out yet what exactly is happening here:
' " IN """"
'---------------------------------------------------

'field names only
'----------------
strFields = MakeFieldDefs(arrFields, arrTypes, lFieldCount, False,
False)
.Execute "INSERT INTO " & _
strTable & _
strFields & _
strSelectFrom & _
" IN """" [" & strConnect & "] " & _
strWhere, _
dbFailOnError

.Close

End With

Set db = Nothing

End Sub

Function SplitSQLOnWhere(strSQL As String) As String()

'splits SQL on first WHERE clause
'not suitable for sub-queries with multiple WHERE
'may need a different split here for GROUP BY etc.
'-------------------------------------------------

Dim lSplitPos As Long
Dim arr(1 To 2) As String

lSplitPos = InStr(1, UCase(strSQL), "WHERE", vbBinaryCompare)

If lSplitPos = 0 Then
lSplitPos = InStr(1, UCase(strSQL), "GROUP BY", vbBinaryCompare)
End If

If lSplitPos = 0 Then
arr(1) = Trim(strSQL)
SplitSQLOnWhere = arr
Exit Function
End If

arr(1) = Trim(Left$(strSQL, lSplitPos - 1))
arr(2) = Trim(Mid$(strSQL, lSplitPos))

SplitSQLOnWhere = arr

End Function

Function GetSelectFields(strSelectFrom As String, bGetAlias As Boolean) As
Variant

Dim arr
Dim strSelect As String
Dim strTemp As String
Dim lStart As Long
Dim lEnd As Long
Dim lSpacePos As Long
Dim lASPos As Long
Dim i As Long

lStart = InStr(6, strSelectFrom, " ", vbBinaryCompare) + 1
lEnd = InStr(lStart, UCase(strSelectFrom), " FROM", vbBinaryCompare)
strSelect = Trim(Mid$(strSelectFrom, _
lStart, _
lEnd - lStart))

'£ is one of the very few non-letter chars allowed as Access fields
'other one is under-score
'take out brackets for if we have for example COUNT(E.ENTRY_ID)
'------------------------------------------------------------------
If InStr(1, strSelect, ",", vbBinaryCompare) = 0 Then
strTemp = Replace(strSelect, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)

lSpacePos = InStr(1, strTemp, " ", vbBinaryCompare)

If lSpacePos > 0 Then
If bGetAlias Then
'to get the ALIAS off the SELECT FIELD
'-------------------------------------
lASPos = InStr(1, UCase(strTemp), " AS ", vbBinaryCompare)
If lASPos = 0 Then
strTemp = Left$(strTemp, lSpacePos - 1)
Else
strTemp = Trim(Mid$(strTemp, lASPos + 4))
End If
End If
Else
strTemp = Left$(strTemp, lSpacePos - 1)
End If
GetSelectFields = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Else

arr = Split(strSelect, ",")

For i = 0 To UBound(arr)
strTemp = Trim(arr(i))
strTemp = Replace(strTemp, "(", "_", 1, -1, vbBinaryCompare)
strTemp = Replace(strTemp, ")", "", 1, -1, vbBinaryCompare)

lSpacePos = InStr(1, strTemp, " ", vbBinaryCompare)

If lSpacePos > 0 Then
If bGetAlias Then
'to get the ALIAS off the SELECT FIELD
'-------------------------------------
lASPos = InStr(1, UCase(strTemp), " AS ", vbBinaryCompare)
If lASPos = 0 Then
strTemp = Left$(strTemp, lSpacePos - 1)
Else
strTemp = Trim(Mid$(strTemp, lASPos + 4))
End If
Else
strTemp = Left$(strTemp, lSpacePos - 1)
End If
End If
arr(i) = Replace(strTemp, ".", "_", 1, -1, vbBinaryCompare)
Next
GetSelectFields = arr
End If

End Function

Function MakeFieldDefs(arrFields As Variant, _
arrTypes As Variant, _
lFieldCount As Long, _
bAddTypes As Boolean, _
bAutoTypes As Boolean) As String

'will attempt to set the data type from the field name:
'ending with _ID: LONG
'with DATE: LONG
'with COUNT: LONG
'with VALUE: DOUBLE
'else: CHAR
'------------------------------------------------------

Dim i As Long
Dim strTemp As String

If bAddTypes Then
If bAutoTypes Then
If lFieldCount = 1 Then
If Right$(UCase(arrFields), 3) = "_ID" Or _
InStr(1, UCase(arrFields), "DATE", vbBinaryCompare) > 0 Or _
InStr(1, UCase(arrFields), "COUNT", vbBinaryCompare) > 0 Or
_
InStr(1, UCase(arrFields), "_BY", vbBinaryCompare) > 0 Or _
InStr(1, UCase(arrFields), "_GP", vbBinaryCompare) > 0 Then
MakeFieldDefs = "(" & arrFields & " " & "LONG" & ")"
Else
If InStr(1, UCase(arrFields), "VALUE", vbBinaryCompare) = 0
Then
MakeFieldDefs = "(" & arrFields & " " & "CHAR" & ")"
Else
MakeFieldDefs = "(" & arrFields & " " & "DOUBLE" & ")"
End If
End If
Else 'If lFieldCount = 1
If Right$(UCase(arrFields(0)), 3) = "_ID" Or _
InStr(1, UCase(arrFields(0)), "DATE", vbBinaryCompare) > 0
Or _
InStr(1, UCase(arrFields(0)), "COUNT", vbBinaryCompare) > 0
Or _
InStr(1, UCase(arrFields(0)), "_BY", vbBinaryCompare) > 0 Or
_
InStr(1, UCase(arrFields(0)), "_GP", vbBinaryCompare) > 0
Then
strTemp = "(" & arrFields(0) & " " & "LONG" & ", "
Else
If InStr(1, UCase(arrFields(0)), "VALUE", vbBinaryCompare) =
0 Then
strTemp = "(" & arrFields(0) & " " & "CHAR" & ", "
Else
strTemp = "(" & arrFields(0) & " " & "DOUBLE" & ", "
End If
End If
For i = 1 To UBound(arrFields)
If i = UBound(arrFields) Then
If Right$(UCase(arrFields(i)), 3) = "_ID" Or _
InStr(1, UCase(arrFields(i)), "DATE", vbBinaryCompare)

0 Or _

Click to expand...

InStr(1, UCase(arrFields(i)), "COUNT",
vbBinaryCompare)

0 Or _

Click to expand...

InStr(1, UCase(arrFields(i)), "_BY", vbBinaryCompare)

0 Or _

Click to expand...

InStr(1, UCase(arrFields(i)), "_GP", vbBinaryCompare)

0 Then

Click to expand...

strTemp = strTemp & arrFields(i) & " " & "LONG" & ")"
Else
If InStr(1, UCase(arrFields(i)), "VALUE",
vbBinaryCompare) = 0 Then
strTemp = strTemp & arrFields(i) & " " & "CHAR" &
")"
Else
strTemp = strTemp & arrFields(i) & " " & "DOUBLE" &
")"
End If
End If
Else
If Right$(UCase(arrFields(i)), 3) = "_ID" Or _
InStr(1, UCase(arrFields(i)), "DATE", vbBinaryCompare)

0 Or _

Click to expand...

InStr(1, UCase(arrFields(i)), "COUNT",
vbBinaryCompare)

0 Or _

Click to expand...

InStr(1, UCase(arrFields(i)), "_BY", vbBinaryCompare)

0 Or _

Click to expand...

InStr(1, UCase(arrFields(i)), "_GP", vbBinaryCompare)

0 Then

Click to expand...

strTemp = strTemp & arrFields(i) & " " & "LONG" & ", "
Else
If InStr(1, UCase(arrFields(i)), "VALUE",
vbBinaryCompare) = 0 Then
strTemp = strTemp & arrFields(i) & " " & "CHAR" &
", "
Else
strTemp = strTemp & arrFields(i) & " " & "DOUBLE" &
", "
End If
End If
End If
Next
End If 'If lFieldCount = 1
Else 'If bAllCHAR
If lFieldCount = 1 Then
MakeFieldDefs = "(" & arrFields & " " & arrTypes & ")"
Else 'lFieldCount = 1
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 'lFieldCount = 1
End If 'If bAllCHAR
Else 'If bAddTypes
If lFieldCount = 1 Then
MakeFieldDefs = " (" & arrFields & ") "
Else 'If lFieldCount = 1
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 'If lFieldCount = 1
End If 'If bAddTypes

MakeFieldDefs = strTemp

End Function

Function CountChar(strChar As String, _
strString As String) As Long

Dim i As Long
Dim n As Long
Dim btArray() As Byte
Dim btAscChar As Byte

If InStr(1, strString, strChar, vbBinaryCompare) = 0 Or _
Len(strString) = 0 Then
CountChar = 0
Exit Function
End If

btAscChar = Asc(strChar)
btArray = strString

For i = 0 To UBound(btArray) - 1 Step 2
If btArray(i) = btAscChar Then
n = n + 1
End If
Next

CountChar = n

End Function

Function IncreaseLastNumberInString(ByVal strString As String) As String

Dim i As Long
Dim btArray() As Byte
Dim lLast As Long
Dim lLastLetterPos As Long

If Asc(Right$(strString, 1)) < 48 Or _
Asc(Right$(strString, 1)) > 57 Then
IncreaseLastNumberInString = strString & "2"
Exit Function
End If

btArray = strString
lLast = UBound(btArray)

For i = lLast To 0 Step -2
If btArray(i) < 48 Or btArray(i) > 57 Then
lLastLetterPos = i \ 2
Exit For
End If
Next

IncreaseLastNumberInString = Left$(strString, lLastLetterPos) & _
Val(Mid$(strString, _
lLastLetterPos + 1)) + 1

End Function

Function bFileExists(ByVal sFile As String) As Boolean

Dim lAttr As Long

On Error Resume Next
lAttr = GetAttr(sFile)
bFileExists = (Err.Number = 0) And ((lAttr And vbDirectory) = 0)
On Error GoTo 0

End Function

RBS

Dirk Goldgar said:

I see you've been very busy. Nice work! It's a pleasure to work with
you.

--
Dirk Goldgar, MS Access MVP
www.datagnostics.com

(please reply to the newsgroup)

Click to expand...

RB Smissaert · May 20, 2006

Just two other questions:
As I have a running, working ADO connection already
when all this gets done, wouldn't it be better to code this
with ADO and use that existing connection?

When and how should I (or can I?) close the new DAO connection?

RBS

RB Smissaert · May 21, 2006

Now have come across a query that falls down, not sure why this is:

This is the original plain SQL:
-----------------------------------
SELECT
E.PATIENT_ID,
E.READ_CODE,
E.START_DATE,
EA1.NUMERIC_VALUE,
EA2.NUMERIC_VALUE
FROM
ENTRY E INNER JOIN
ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND
E.READ_CODE LIKE '246%') INNER JOIN
ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND
EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID)
WHERE
NOT EA1.NUMERIC_VALUE IS NULL AND
NOT EA2.NUMERIC_VALUE IS NULL AND
EA1.NUMERIC_VALUE > 180

This will be made from it to get data into the Access table:
--------------------------------------------------------------------
INSERT INTO DDDDD(E_PATIENT_ID, E_READ_CODE, E_START_DATE,
EA1_NUMERIC_VALUE, EA2_NUMERIC_VALUE) SELECT E.PATIENT_ID, E.READ_CODE,
E.START_DATE, EA1.NUMERIC_VALUE, EA2.NUMERIC_VALUE FROM ENTRY E INNER JOIN
ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND E.READ_CODE LIKE
'246%') INNER JOIN ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID =
EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID) IN ""
[ODBC;DB=C:\torex\synergy\meddata\s6000\db\s6.gdb;DSN=System
6000;UID=sysdba;PWD=*******;OLDMETADATA=1;] WHERE NOT EA1.NUMERIC_VALUE IS
NULL AND NOT EA2.NUMERIC_VALUE IS NULL AND EA1.NUMERIC_VALUE > 180

And this is the error message:
----------------------------------
Syntax error (missing operator) in query expression '(E.ENTRY_ID =
EL1.PARENT_ENTRY_ID AND E.READ_CODE LIKE '246%') INNER JOIN ENTRYLINK EL2 ON
(EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID >
EL1.CHILD_ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID =
EA1.ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID =
EA2.ENTRY_ID)'.
Error number: 3075

I can see that the last SQL is invalid, no SELECT etc., but why did it pick
this up?
The actual string to be executed looks fine.
Did it somehow get confused with the multiple joins?
Thanks for any advice.

RBS

RB Smissaert · May 21, 2006

It seems that 2 joins are fine, but more than that there will be an error.
I am sure there must be a way round this, but if not then I can forgeabout
re-writing my app with Access tables with this SELECT INTO construction.

RBS

RB Smissaert said:
Now have come across a query that falls down, not sure why this is:

This is the original plain SQL:
-----------------------------------
SELECT
E.PATIENT_ID,
E.READ_CODE,
E.START_DATE,
EA1.NUMERIC_VALUE,
EA2.NUMERIC_VALUE
FROM
ENTRY E INNER JOIN
ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND
E.READ_CODE LIKE '246%') INNER JOIN
ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND
EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID)
WHERE
NOT EA1.NUMERIC_VALUE IS NULL AND
NOT EA2.NUMERIC_VALUE IS NULL AND
EA1.NUMERIC_VALUE > 180

This will be made from it to get data into the Access table:
--------------------------------------------------------------------
INSERT INTO DDDDD(E_PATIENT_ID, E_READ_CODE, E_START_DATE,
EA1_NUMERIC_VALUE, EA2_NUMERIC_VALUE) SELECT E.PATIENT_ID, E.READ_CODE,
E.START_DATE, EA1.NUMERIC_VALUE, EA2.NUMERIC_VALUE FROM ENTRY E INNER
JOIN ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND E.READ_CODE
LIKE '246%') INNER JOIN ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID =
EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER
JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID) IN ""
[ODBC;DB=C:\torex\synergy\meddata\s6000\db\s6.gdb;DSN=System
6000;UID=sysdba;PWD=*******;OLDMETADATA=1;] WHERE NOT EA1.NUMERIC_VALUE IS
NULL AND NOT EA2.NUMERIC_VALUE IS NULL AND EA1.NUMERIC_VALUE > 180

And this is the error message:
----------------------------------
Syntax error (missing operator) in query expression '(E.ENTRY_ID =
EL1.PARENT_ENTRY_ID AND E.READ_CODE LIKE '246%') INNER JOIN ENTRYLINK EL2
ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID >
EL1.CHILD_ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID
= EA1.ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID =
EA2.ENTRY_ID)'.
Error number: 3075

I can see that the last SQL is invalid, no SELECT etc., but why did it
pick this up?
The actual string to be executed looks fine.
Did it somehow get confused with the multiple joins?
Thanks for any advice.

RBS

RB Smissaert said:

What would be the best (fastest) way to:
create a new .mdb file with a table with specified fields.
run a SQL query on an Interbase database via ODBC.
Put the rows produced by this query in the Access table.

I think this would work with looping through a recordset, but
would it somehow be possible to do it directly with an INSERT
statement?

I have to do this from Excel VBA.
Thanks for any advice.

RBS

Click to expand...

RB Smissaert · May 22, 2006

Got this sorted now.
Can't say I understand, but putting a linebreak before:
(E.ENTRY_ID = etc.
solved it.

RBS

RB Smissaert said:
Now have come across a query that falls down, not sure why this is:

This is the original plain SQL:
-----------------------------------
SELECT
E.PATIENT_ID,
E.READ_CODE,
E.START_DATE,
EA1.NUMERIC_VALUE,
EA2.NUMERIC_VALUE
FROM
ENTRY E INNER JOIN
ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND
E.READ_CODE LIKE '246%') INNER JOIN
ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND
EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID)
WHERE
NOT EA1.NUMERIC_VALUE IS NULL AND
NOT EA2.NUMERIC_VALUE IS NULL AND
EA1.NUMERIC_VALUE > 180

This will be made from it to get data into the Access table:
--------------------------------------------------------------------
INSERT INTO DDDDD(E_PATIENT_ID, E_READ_CODE, E_START_DATE,
EA1_NUMERIC_VALUE, EA2_NUMERIC_VALUE) SELECT E.PATIENT_ID, E.READ_CODE,
E.START_DATE, EA1.NUMERIC_VALUE, EA2.NUMERIC_VALUE FROM ENTRY E INNER
JOIN ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND E.READ_CODE
LIKE '246%') INNER JOIN ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID =
EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER
JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID) IN ""
[ODBC;DB=C:\torex\synergy\meddata\s6000\db\s6.gdb;DSN=System
6000;UID=sysdba;PWD=*******;OLDMETADATA=1;] WHERE NOT EA1.NUMERIC_VALUE IS
NULL AND NOT EA2.NUMERIC_VALUE IS NULL AND EA1.NUMERIC_VALUE > 180

And this is the error message:
----------------------------------
Syntax error (missing operator) in query expression '(E.ENTRY_ID =
EL1.PARENT_ENTRY_ID AND E.READ_CODE LIKE '246%') INNER JOIN ENTRYLINK EL2
ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID >
EL1.CHILD_ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID
= EA1.ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID =
EA2.ENTRY_ID)'.
Error number: 3075

I can see that the last SQL is invalid, no SELECT etc., but why did it
pick this up?
The actual string to be executed looks fine.
Did it somehow get confused with the multiple joins?
Thanks for any advice.

RBS

RB Smissaert said:

What would be the best (fastest) way to:
create a new .mdb file with a table with specified fields.
run a SQL query on an Interbase database via ODBC.
Put the rows produced by this query in the Access table.

I think this would work with looping through a recordset, but
would it somehow be possible to do it directly with an INSERT
statement?

I have to do this from Excel VBA.
Thanks for any advice.

RBS

Click to expand...

RB Smissaert · May 23, 2006

I think this was just a silly mistake, not having any space (or linebreak)
where there should be one.
So, all sorted.

RBS

RB Smissaert said:
Got this sorted now.
Can't say I understand, but putting a linebreak before:
(E.ENTRY_ID = etc.
solved it.

RBS

RB Smissaert said:

Now have come across a query that falls down, not sure why this is:

This is the original plain SQL:
-----------------------------------
SELECT
E.PATIENT_ID,
E.READ_CODE,
E.START_DATE,
EA1.NUMERIC_VALUE,
EA2.NUMERIC_VALUE
FROM
ENTRY E INNER JOIN
ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND
E.READ_CODE LIKE '246%') INNER JOIN
ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND
EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER JOIN
ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID)
WHERE
NOT EA1.NUMERIC_VALUE IS NULL AND
NOT EA2.NUMERIC_VALUE IS NULL AND
EA1.NUMERIC_VALUE > 180

This will be made from it to get data into the Access table:
--------------------------------------------------------------------
INSERT INTO DDDDD(E_PATIENT_ID, E_READ_CODE, E_START_DATE,
EA1_NUMERIC_VALUE, EA2_NUMERIC_VALUE) SELECT E.PATIENT_ID, E.READ_CODE,
E.START_DATE, EA1.NUMERIC_VALUE, EA2.NUMERIC_VALUE FROM ENTRY E INNER
JOIN ENTRYLINK EL1 ON (E.ENTRY_ID = EL1.PARENT_ENTRY_ID AND E.READ_CODE
LIKE '246%') INNER JOIN ENTRYLINK EL2 ON (EL1.PARENT_ENTRY_ID =
EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID > EL1.CHILD_ENTRY_ID) INNER
JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID = EA1.ENTRY_ID) INNER
JOIN ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID = EA2.ENTRY_ID) IN ""
[ODBC;DB=C:\torex\synergy\meddata\s6000\db\s6.gdb;DSN=System
6000;UID=sysdba;PWD=*******;OLDMETADATA=1;] WHERE NOT EA1.NUMERIC_VALUE
IS NULL AND NOT EA2.NUMERIC_VALUE IS NULL AND EA1.NUMERIC_VALUE > 180

And this is the error message:
----------------------------------
Syntax error (missing operator) in query expression '(E.ENTRY_ID =
EL1.PARENT_ENTRY_ID AND E.READ_CODE LIKE '246%') INNER JOIN ENTRYLINK EL2
ON (EL1.PARENT_ENTRY_ID = EL2.PARENT_ENTRY_ID AND EL2.CHILD_ENTRY_ID >
EL1.CHILD_ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA1 ON (EL1.CHILD_ENTRY_ID
= EA1.ENTRY_ID) INNER JOIN ENTRY_ATTRIBUTE EA2 ON (EL2.CHILD_ENTRY_ID =
EA2.ENTRY_ID)'.
Error number: 3075

I can see that the last SQL is invalid, no SELECT etc., but why did it
pick this up?
The actual string to be executed looks fine.
Did it somehow get confused with the multiple joins?
Thanks for any advice.

RBS

RB Smissaert said:

What would be the best (fastest) way to:
create a new .mdb file with a table with specified fields.
run a SQL query on an Interbase database via ODBC.
Put the rows produced by this query in the Access table.

I think this would work with looping through a recordset, but
would it somehow be possible to do it directly with an INSERT
statement?

I have to do this from Excel VBA.
Thanks for any advice.

RBS

Click to expand...

Click to expand...

Insert into error	6	Oct 20, 2006
Project advice	4	May 19, 2006
Convert OR to UNION	3	Jun 14, 2007
Table Security in Access 2013	1	Nov 1, 2017
slow append query from a pass through query	4	Sep 21, 2007
Convert Interbase 7 tables into Access 2000	1	Jun 25, 2004
giving a presentation on why accountants should learn someaccess...is what i say fairly accurate?	1	Mar 24, 2013
Update table using data in a different .mdb	0	Dec 16, 2011

Interbase data to Access

RB Smissaert

Pieter Wijnen

RB Smissaert

RB Smissaert

RB Smissaert

Douglas J. Steele

RB Smissaert

RB Smissaert

RB Smissaert

RB Smissaert

RB Smissaert

RB Smissaert

RB Smissaert

RB Smissaert

Ask a Question

Similar Threads