|
|
Post by metro on Oct 12, 2018 1:58:34 GMT -5
Not sure if any of this will help
'// Here we create a new database connection.
' You can open as many connections as you want
' by Using "newdb$" and specifing a unique name.
'// functions:
'// newdb$( "Name of DataBase", "DSN Name", "User Id", "Password"), returns "-1" if fails
' and returns name of database if success...
'// runSQL( "QB", SQL$ ), DataBase Name, SQL Command
'// getdbdata$("Data Base Name", "Rows"), returns the number of rows gotten
' from the last runSQL$
'// getdbdata$("Data Base Name", "Cols"), returns the number of Columns gotten
' from the last runSQL$
'// RowCol$( "Name of DataBase", Row, Column, "Column Name"), returns the data in that Row/Col
' (Column Name)
' You can specify a Column NUMBER, in Column, or Column Name in a String for
' it to match, if you have text in the Column Name field, it will
' ignore the data in the Column field. If you're using the Column
' number field, leave the "Column Name" field blank: ""
'// closedb("DataBase Name"), closes the database
'// ShutDown(), use this to terminate the program
'// it frees all the memory we've allocated
'// during use of the program and ends the
'// program
dbName$ = newdb$("QB", "test32", "sa", "1234")
ret = runSQL(dbName$, "SELECT * FROM employee")
Rows = val(getdbdata$(dbName$, "Rows"))
Cols = val(getdbdata$(dbName$, "Cols"))
for k = 1 to Rows
for y = 1 to Cols
Print RowCol$(dbName$, k, y, ""); " ";
'// You could also use, to get Data from a single column:
' "Print RolCol$( dbName$, 1, 0, "Name" )" and it would
' print just the Column named "Name" from Row 1
next y
print
next k
[quit]
ret = closedb("QB")
ret = ShutDown()
'************************** ODBC FOOTER ************************
Function GlobalAlloc( dwBytes )
uFlags = hexdec("42") ' was 42 _GMEM_MOVEABLE or _GMEM_ZEROINIT
CallDll #kernel32, "GlobalAlloc",_
uFlags as UShort,_
dwBytes as ulong,_
GlobalAlloc as long
end Function
Function GlobalLock( hMem )
CallDll #kernel32, "GlobalLock", hMem as long, _
GlobalLock as long
end Function
Function GlobalFree( hMem )
ret = GlobalUnlock( hMem )
CallDll #kernel32, "GlobalFree", hMem as long, _
GlobalFree as long
if GlobalFree = hMem then
'"Failed to Free Memory Handle: "; hMem
else
'"Freed Memory Handle: "; hMem
end if
end Function
Function GlobalUnlock( hMem )
'returns a pointer to the first byte of the memory block.
'the return value is NULL if fail.
CallDll #kernel32, "GlobalUnlock", hMem as long, _
GlobalUnlock as long
end Function
Function GlobalReAlloc( hMem, dwBytes )
'returns the handle of the newly allocated memory object.
'the return value is NULL if fail.
uFlags = hexdec("42") 'was 42
CallDll #kernel32, "GlobalReAlloc", hMem as long, dwBytes as ulong,_
uFlags as long, GlobalReAlloc as long
end Function
function getbacktalk(hType, handle, recNum)
SQLSTATE$ = space$(5) + chr$(0)
mText$ = space$(100) + chr$(0)
lenmText = len(mText$)
calldll #odbc, "SQLGetDiagRec",_
hType as Long,_
handle as ULong,_
recNum as Long,_
SQLSTATE$ as Ptr,_
SqlError as Struct,_
mText$ as Ptr,_
lenmText as Long,_
mTextRet as Struct,_
getbacktalk as Long
end function
function ClearMemory( mPtr, dwBytes )
calldll #kernel32, "RtlZeroMemory",_
mPtr as Long,_
dbBytes as Long,_
Ret as Void
end function
function newdb$(dbName$, DataBaseName$, UserName$, Password$)
Ret = GlobalUnlock( hDbList(1) )
NewBytes = ((DataBasesOpen(1) + 1) * 42)
if DataBasesOpen(1) > 0 then
Ret = GlobalReAlloc( hDbList(1), NewBytes )
else
ret = defineodbc()
open "odbc32.dll" for dll as #odbc
Ret = GlobalAlloc( NewBytes )
end if
if Ret <> 0 then
hDbList(1) = Ret
DbListPtr(1) = GlobalLock( hDbList(1) )
'"DbListPtr(1): "; DbListPtr(1); " (memory Address)"
DataBasesOpen(1) = DataBasesOpen(1) + 1
writeAddress = DbListPtr(1) + ((DataBasesOpen(1) - 1) * 42)
if len(dbName$) > 9 then
value$ = left$(value$, 9)
end if
dbName$ = dbName$ + space$(9 - len(value$)) + chr$(0)
DataBases.Name$.struct = dbName$
DataBases.hColname.struct = 0
DataBases.hResult.struct = 0
DataBases.hRDataLenBuff.struct = 0
DataBases.hStmt.struct = 0
DataBases.hDbc.struct = 0
DataBases.hEnv.struct = 0
DataBases.Rows.struct = 0
DataBases.Cols.struct = 0
'"Writing at mem address: "; writeAddress
calldll #kernel32, "RtlMoveMemory",_
writeAddress as ULong,_
DataBases as Struct,_
42 as Long,_
Ret as Void
newdb$ = trim$(dbName$)
else
newdb$ = "-1"
notice "Re-Alloc Memory Failed."
end if
'"Calling Dll to Open Environment..."
SHE = SQL.HANDLE.ENV(1)
SNQ = SQL.NULL.HANDLE(1)
calldll #odbc, "SQLAllocHandle",_
SHE as Long,_
SNQ as Long,_ '// Do this b/c this is the first handle we're allocating
hOut as Struct,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
'"Open Environment Failed..."
'"Return Code: "; dechex$(Ret)
err = getbacktalk(SQL.HANDLE.ENV(1), hEnv, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
hEnv = hOut.handle.struct
'"Success, Environment Object Handle: "; hEnv
end if
[SQLSetEnvAttr]
'// Setting Environment Attributes
'"Setting Environment Attributes, using ODBC v3"
SAOV = SQL.ATTR.ODBC.VERSION(1)
SOD = SQL.OV.ODBC3(1)
calldll #odbc, "SQLSetEnvAttr",_
hEnv as ULong,_
SAOV as Long,_
SOD as Long,_
0 as Long,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
'"Set Attributes Failed (use ODBC v3)..."
'"Return Code: "; dechex$(Ret)
err = getbacktalk(SQL.HANDLE.ENV(1), hEnv, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
'"Set Attributes Sucess (use ODBC v3)..."
end if
[SQLAllocHandle.DBC]
'// Allocate CONNECTION handle...
'"Allocating Database Connection Handle..."
SHD = SQL.HANDLE.DBC(1)
calldll #odbc, "SQLAllocHandle",_
SHD as Long,_
hEnv as ULong,_
hOut as Struct,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
'"Allocate / Create connection FAILED..."
'"Return Code: "; dechex$(Ret)
err = getbacktalk(SQL.HANDLE.ENV(1), hEnv, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
hDbc = hOut.handle.struct
end if
[SQLSetConnectAttr]
SLT = SQL.LOGIN.TIMEOUT
calldll #odbc, "SQLSetConnectAttr",_ 'hDbc, SQL_LOGIN_TIMEOUT, 5, 0
hDbc as ULong,_
SLT as Long,_
5 as Long,_
0 as Long,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
err = getbacktalk(SQL.HANDLE.DBC(1), hDbc, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
end if
SAOC = SQL.ATTR.ODBC.CURSORS(1)
SCUO = SQL.CUR.USE.ODBC(1)
calldll #odbc, "SQLSetConnectAttr",_ 'hDbc, SQL_LOGIN_TIMEOUT, 5, 0
hDbc as ULong,_
SAOC as Long,_
SCUO as ULong,_
0 as Long,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
err = getbacktalk(SQL.HANDLE.DBC(1), hDbc, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
'"Non-Scrollable Cursor Set Successfully..."
end if
' '// Set Quiet Mode, no pop-ups or Driver Messages//
' '"Setting Quiet Mode Options..."
' calldll #odbc, "SQLSetConnectAttr",_ 'hDbc, SQL_LOGIN_TIMEOUT, 5, 0
' hDbc as ULong,_
' SQL.ATTR.QUIET.MODE(1) as Long,_
' 0 as Long,_
' 0 as Long,_
' Ret as Short
'
' if Ret <> SQL.SUCCESS(1) then
' '"Error Setting Quiet Mode..."
' '"Return Code: "; dechex$(Ret)
' ret = ShutDown()
'
' else
' '"Quiet Mode Set Successfully..."
'
[SQLConnect]
csLen = len(DataBaseName$)
csLength.size.struct = len(DataBaseName$)
' UserName$ = "sa"
' UserName$ = "Admin"
unLen = len(UserName$)
unLength.size.struct = len(UserName$)
' Password$ = "314159"
' Password$ = "7777"
pwLen = len(Password$)
pwLength.size.struct = len(Password$)
calldll #odbc, "SQLConnect",_
hDbc as ULong,_
DataBaseName$ as Ptr,_
csLen as Long,_
UserName$ as Ptr,_
unLen as Long,_
Password$ as Ptr,_
pwLen as Long,_
Ret as Short
if (Ret <> SQL.SUCCESS(1)) or (Ret <> SQL.SUCCESS.WITH.INFO(1)) then
'"Getting Error info..."
Err = getbacktalk(SQL.HANDLE.DBC(1), hDbc, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
'"Connected to DataBase SUCCESS..."
end if
ret = setdbdata(dbName$, "hDbc", str$(hDbc))
ret = setdbdata(dbName$, "hEnv", str$(hEnv))
end function
function setdbdata(dbName$, field$, value$)
if len(dbName$) > 9 then
dbName$ = left$(dbName$, 9)
end if
dbName$ = dbName$ + space$(9 - len(dbName$)) + chr$(0)
dbName$ = trim$(dbName$)
if DataBasesOpen(1) > 0 then
select case upper$(field$)
case "Name$"
if len(value$) > 9 then
value$ = left$(value$, 9)
end if
offset = 0
value = -1
case "HCOLNAME"
offset = 10
value = val(value$)
case "HRESULT"
value = val(value$)
offset = 14
case "HRDATALENBUFF"
value = val(value$)
offset = 18
case "HSTMT"
value = val(value$)
offset = 22
case "HDBC"
value = val(value$)
offset = 26
case "HENV"
value = val(value$)
offset = 30
case "ROWS"
value = val(value$)
offset = 34
case "COLS"
value = val(value$)
offset = 38
case else
setdbdata = -1
end select
for k = 1 to DataBasesOpen(1)
curAddress = DbListPtr(1) + ((k-1) * 42)
DataBases.struct = curAddress
if trim$(upper$(DataBases.Name$.struct)) = upper$(dbName$) then
' '"Setting Data for DB: "; dbName$
writeAddress = curAddress + offset
if (value > -1) then
' '"Putting: "; value;" to address: "; writeAddress
csLength.size.struct = value
calldll #kernel32, "RtlMoveMemory",_
writeAddress as ULong,_
csLength as Struct,_
4 as Long,_
Ret as Void
else
value$ = value$ + space$(9 - len(value$)) + chr$(0)
calldll #kernel32, "RtlMoveMemory",_
writeAddress as ULong,_
value$ as Ptr,_
10 as Long,_
Ret as Void
end if
setdbdata = 0
exit for
end if
next k
if k > DataBasesOpen(1) then
setdbdata = -1
end if
else
setdbdata = -1
notice "No DataBases Open!"
end if
end function
function getdbdata$(dbName$, field$)
if len(dbName$) > 9 then
dbName$ = left$(dbName$, 9)
end if
dbName$ = dbName$ + space$(9 - len(dbName$)) + chr$(0)
dbName$ = trim$(dbName$)
' print
if DataBasesOpen(1) > 0 then
k = 1
do
DataBases.struct = DbListPtr(1) + ((k-1) * 42)
' '"Reading MEM Address: "; DbListPtr(1) + ((k-1) * 42)
' '"From Struct: ";trim$(DataBases.Name$.struct)
k = k + 1
loop until ((k = DataBasesOpen(1) + 1) or (trim$(DataBases.Name$.struct) = dbName$))
if (k - 1) <= DataBasesOpen(1) then
select case upper$(field$)
case "NAME$"
' '"Found DataBase Name in memory..."
getdbdata$ = trim$(DataBases.Name$.struct)
case "HCOLNAME"
getdbdata$ = trim$(str$(DataBases.hColname.struct))
case "HRESULT"
getdbdata$ = trim$(str$(DataBases.hResult.struct))
case "HRDATALENBUFF"
getdbdata$ = trim$(str$(DataBases.hRDataLenBuff.struct))
case "HSTMT"
getdbdata$ = trim$(str$(DataBases.hStmt.struct))
case "HDBC"
getdbdata$ = trim$(str$(DataBases.hDbc.struct))
case "HENV"
getdbdata$ = trim$(str$(DataBases.hEnv.struct))
case "ROWS"
getdbdata$ = trim$(str$(DataBases.Rows.struct))
case "COLS"
getdbdata$ = trim$(str$(DataBases.Cols.struct))
case else
getdbdata$ = "-1 Data Field Not Found"
end select
else
getdbdata$ = "-1 DataBase Name Not Found."
end if
else
getdbdata$ = "-1"
notice "No DataBases Open!"
end if
end function
function Results$(dB$, Row, Col)
end function
function ShutDown()
Ret = GlobalFree( hMem )
Ret = GlobalFree( hstrLenBuff )
Ret = GlobalFree( hDataLenBuff )
for k = 1 to DataBasesOpen(1)
if k = 1 then
close #odbc
end if
DataBases.struct = DbListPtr(1) + ((k-1) * 42)
Ret = GlobalFree(DataBases.hColname.struct)
Ret = GlobalFree(DataBases.hResult.struct)
Ret = GlobalFree(DataBases.hRDataLenBuff.struct)
next k
Ret = GlobalFree( hDbList(1) )
End
end function
function defineodbc()
' // Declare SQL Contants
SQL.FETCH.NEXT(1) = 1
SQL.FETCH.FIRST(1) = 2
SQL.FETCH.LAST(1) = 3
SQL.FETCH.PRIOR(1) = 4
SQL.FETCH.ABSOLUTE(1) = 5
SQL.FETCH.RELATIVE(1) = 6
SQL.FETCH.BOOKMARK(1) = 8
SQL.HANDLE.ENV(1) = 1
SQL.HANDLE.DBC(1) = 2
SQL.HANDLE.STMT(1) = 3
SQL.NULL.HANDLE(1) = 0
SQL.NULL.DATA(1) = -1
SQL.SUCCESS(1) = 0
SQL.SUCCESS.WITH.INFO(1) = 1
SQL.ERROR(1) = -1
SQL.ATTR.ODBC.VERSION(1) = 200
SQL.OV.ODBC3(1) = 3
SQL.MAX.NAME.SIZE(1) = 128
SQL.NO.DATA.FOUND(1) = 100
SQL.CHAR(1) = 1
SQL.C.CHAR(1) = SQL.CHAR(1)
SQL.ATTR.ODBC.CURSORS(1) = 110
SQL.CUR.USE.ODBC(1) = 1
SQL.ATTR.QUIET.MODE(1) = 111
SQL.DESC.LABEL(1) = 20
SQL.DESC.LENGTH(1) = 3
struct DataBases,_ 'Length of this Struct is 42
Name$ as char[10],_ ' Name Of DataBase
hColname as Long,_ ' Memory Pointer to Column names, delimited by chr$(1) set before Fetch
hResult as Long,_ ' Result Set Pointer, delimited by chr$(1) set at Fetch
hRDataLenBuff as Long,_
hStmt as ULong,_ 'Statement Handle
hDbc as ULong,_ 'DataBase Handle
hEnv as ULong,_ 'Environment Handle
Rows as Long,_ 'Rows in Results, set by last query
Cols as Long 'Cols in Results, set by last query
struct SqlError,_
nePointer as Short
struct intPtr,_
size as Short
struct mTextRet,_
size as Long
struct hOut,_
handle as ULong
struct csLength,_
size as Long
struct unLength,_
size as Long
struct pwLength,_
size as Long
struct dbOut,_
size as Long
struct dbOut2,_
size as Long
struct number,_
columns as Long
struct szOut,_
string as Ptr
defineall = 1
end function
function GetLastError()
calldll #kernel32, "GetLastError",_
GetLastError as Long
end function
function RowCol$(dbName$, Row, Col, ColName$)
if ColName$ <> "" then
hColName = val( getdbdata$( dbName$, "hColName" ) )
hColNamePtr = GlobalLock ( hColName )
for k = 1 to val(getdbdata$( dbName$, "Cols" ) )
cName$ = space$(254) + chr$(0)
calldll #kernel32, "RtlMoveMemory",_
cName$ as Ptr,_
hColNamePtr as ULong,_
255 as Long,_
Ret as Void
hColNamePtr = hColNamePtr + 255
if trim$(upper$(cName$)) = trim$(upper$(ColName$)) then
Col = k
ret = GlobalUnlock( hColName )
exit for
end if
next k
else
if ColName$ <> "" then
Col = 0
end if
end if
Rows = val(getdbdata$(dbName$, "Rows"))
Cols = val(getdbdata$(dbName$, "Cols"))
if ((Row >= 1) and (Col >= 1)) and ((Row <= Rows) and (Col <= Cols)) then
hResultPtr = GlobalLock( val(getdbdata$(dbName$, "hResult")) )
if hResultPtr = 0 then
notice "Failed to get Memory Address Pointer to hResult at RowCol$"
ret = ShutDown()
end if
hRDataLenBuffPtr = GlobalLock( val(getdbdata$(dbName$, "hRDataLenBuff")) )
if hResultPtr = 0 then
notice "Failed to get Memory Address Pointer to hRDataLenBuff at RowCol$"
ret = ShutDown()
end if
Rows = val(getdbdata$(dbName$, "Rows"))
Cols = val(getdbdata$(dbName$, "Cols"))
Record = ((Row - 1) * Cols) + Col
RecAddr = hRDataLenBuffPtr + ((Record - 1) * 8)
dbOut.struct = RecAddr 'NumBytes
dbOut2.struct = (RecAddr + 4) 'DataAddress
hResultPtr2 = hResultPtr + dbOut2.size.struct
dwBytes = dbOut.size.struct
if dwBytes <> 0 then
oName$ = space$(dwBytes) + chr$(0)
calldll #kernel32, "RtlMoveMemory",_
oName$ as Ptr,_
hResultPtr2 as ULong,_
dwBytes as Long,_
Ret as Long
RowCol$ = oName$
else
RowCol$ = "<NULL>"
end if
Ret = GlobalUnlock( hResult )
Ret = GlobalUnlock( hRDataLenBuff )
else
RowCol$ = "<ERROR>"
end if
end function
function closedb(dbName$)
hDbc = val(getdbdata$(dbName$, "hDbc"))
hEnv = val(getdbdata$(dbName$, "hEnv"))
[SQLDisconnect]
calldll #odbc, "SQLDisconnect",_
hDbc as ULong,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
ret = ShutDown()
else
'"Database disconnect..SUCCESS"
end if
[SQLFreeHandle.DBC]
SHD = SQL.HANDLE.DBC(1)
calldll #odbc, "SQLFreeHandle",_
SHD as Long,_
hDbc as ULong,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
ret = ShutDown()
else
'"Connection Handle Freed..SUCCESS"
end if
[SQLFreeHandle.ENV]
SHE = SQL.HANDLE.ENV(1)
calldll #odbc, "SQLFreeHandle",_
SHE as Long,_
hEnv as ULong,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
ret = ShutDown()
else
'"Environment Handle Freed..SUCCESS"
end if
end function
function runSQL(dbName$, SQL$)
runSQL = 0
hDbc = val( getdbdata$(dbName$, "hDbc") )
hEnv = val( getdbdata$(dbName$, "hEnv") )
hStmt = val( getdbdata$(dbName$, "hStmt") )
[SQLAllocHandle.STMT]
SHS = SQL.HANDLE.STMT(1)
calldll #odbc, "SQLAllocHandle",_
SHS as Long,_
hDbc as ULong,_
hOut as Struct,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
err = getbacktalk(SQL.HANDLE.STMT(1), hStmt, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
hStmt = hOut.handle.struct
'"Statement Object Created, handle returned: "; hStmt
end if
[SQLSetStmtAttr]
'// Setting Statement Attributes
'SQLSetStmtAttrLong(hStmt, SQL_ATTR_CURSOR_TYPE,SQL_CURSOR_STATIC, 0)
' '"Setting SQL Statement Attributes..."
' SACT = SQL.ATTR.CURSOR.TYPE
' SCS = SQL.CURSOR.STATIC
' calldll #odbc, "SQLSetStmtAttr",_
' hStmt as ULong,_
' SACT as Long,_
' SCS as Long,_
' 0 as Long,_
' Ret as Short
'
' if Ret <> SQL.SUCCESS(1) then
' '"Error Setting Static Cursor state in Statement..."
' '"Return Code: "; dechex$(Ret)
' err = getbacktalk(SQL.HANDLE.STMT(1), hStmt, 1)
' if Ret = SQL.ERROR(1) then
' ret = ShutDown()
' end if
' else
' '"Cursor set to static..SUCCESS"
' end if
'// ***Maybe Continue setting SQLSetStmtAttr here.....
'// maybe use SQL_ATTR_QUERY_TIMEOUT...
'// maybe use SQL_ATTR_MAX_ROWS
'// **************************************************
[SQLExecDirect]
lenSQL = len(SQL$)
calldll #odbc, "SQLExecDirect",_
hStmt as ULong,_
SQL$ as Ptr,_
lenSQL as Long,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
err = getbacktalk(SQL.HANDLE.STMT(1), hStmt, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
'"SQL Execute SUCCESS.."
end if
'// Count number of Cols in Result Set
[SQLNumResultCols]
Cols = 0
calldll #odbc, "SQLNumResultCols",_
hStmt as ULong,_
number as Struct,_
Ret as Short
Cols = number.columns.struct
[SQLGetColNames]
temp = val( getdbdata$(dbName$, "hColName") )
if temp > 0 then
if GlobalFree( temp ) <> 0 then' Free Previous Column-Name Handle
notice "Failed to free old hColName!"
end if
end if
temp = val( getdbdata$(dbName$, "hDataLenBuff") )
if temp > 0 then
if GlobalFree( temp ) <> 0 then' Free Previous Column-Name Handle
notice "Failed to free old hDataLenBuff!"
end if
end if
if hColName <> 0 then
hColName = GlobalReAlloc( val( getdbdata$(dbName$, "hColName") ), 255 * Cols )
if hColName = 0 then
notice "Failed to Re-Alloc hColName!"
ret = ShutDown()
end if
else
hColName = GlobalAlloc( 255 * Cols )
end if
hDataLenBuff = GlobalAlloc( 4 * Cols )
hColNamePtr = GlobalLock( hColName )
hDataLenBuffPtr = GlobalLock( hDataLenBuff )
hDataLenBuffPtrbak = hDataLenBuffPtr
maxBytes = 0
for k = 1 to Cols
cName$ = Space$(253) + Chr$(1) + Chr$(0)
Calldll #odbc, "SQLColAttribute",_
hStmt As Long,_
k As Short, _
18 As Short,_ 'was SQL.DESC.LABEL(1)
hColNamePtr As ULong,_
255 As Short,_
csLength As Struct,_
intPtr As Struct,_
ret As Short
Calldll #odbc, "SQLColAttribute",_
hStmt As Long,_
k As Short, _
3 As Short,_ 'was SQL.DESC.LENGTH(1)
0 As Long,_
0 As Short,_
0 as Long,_'csLength As Struct,_
hDataLenBuffPtr As ULong,_
ret As Short
dbOut.struct = hDataLenBuffPtr
if dbOut.size.struct < 255 then
dbOut.size.struct = 255
calldll #kernel32, "RtlMoveMemory",_
hDataLenBuffPtr as ULong,_
dbOut as Struct,_
4 as Long,_
Ret as Void
end if
maxBytes = maxBytes + dbOut.size.struct
hColNamePtr = hColNamePtr + 255
hDataLenBuffPtr = hDataLenBuffPtr + 4
next k
maxBytes = maxBytes + Cols
if GlobalUnlock( hColName ) <> 0 then
notice "Failed to UnLock hColName!"
ret = ShutDown()
end if
ret = setdbdata(dbName$, "hColName", str$(hColName))
ret = setdbdata(dbName$, "hStmt", str$(hStmt))
ret = setdbdata(dbName$, "hDbc", str$(hDbc))
ret = setdbdata(dbName$, "hEnv", str$(hEnv))
ret = setdbdata(dbName$, "Rows", str$(Rows))
ret = setdbdata(dbName$, "Cols", str$(Cols))
adrPtr = GlobalLock( val(getdbdata$(dbName$, "hColName")) )
hDataLenBuffPtr = hDataLenBuffPtrbak
hDataLenBuffPtrbak = 0
if adrPtr > 0 then
for k = 1 to Cols
dbOut.struct = hDataLenBuffPtr + ((k-1) * 4)
next k
ret = GlobalUnlock( hColName )
if ret <> 0 then
notice "Failed to UnLock hColName! ERROR: "; ret
ret = ShutDown()
end if
else
notice "No Address Pointer, Trying to display Column Names!"
ret = ShutDown()
end if
[SQLBindCol]
allocBytes = (maxBytes)
hMem = GlobalAlloc( allocBytes )
mPtr = GlobalLock( hMem )
strLenBytes = (Cols * 4)
hstrLenBuff = GlobalAlloc( strLenBytes )
strLenPtr = GlobalLock( hstrLenBuff )
TargetValuePtr = mPtr
for k = 1 to Cols
dbOut.struct = hDataLenBuffPtr + ((k-1) * 4)
TargetValueSize = dbOut.size.struct
strLenPtr2 = strLenPtr + ((k-1) * 4)
SCC = SQL.C.CHAR(1)
TargetValueSize = TargetValueSize + 1
calldll #odbc, "SQLBindCol",_
hStmt as ULong,_
k as Short,_
SCC as Short,_
TargetValuePtr as Long,_
TargetValueSize as Long,_
strLenPtr2 as Long,_
Ret as Short
TargetValuePtr = TargetValuePtr + dbOut.size.struct
if Ret = SQL.ERROR(1) then
ret = getbacktalk(SQL.HANDLE.STMT(1), hStmt, k)
ret = ShutDown()
end if
next k
if val(getdbdata$(dbName$, "HRDATALENBUFF")) <> 0 then
ret = GlobalUnlock( hRDataLenBuff )
ret = GlobalFree( hRDataLenBuff )
hRDataLenBuff = GlobalAlloc( Cols * 8 )
if hRDataLenBuff = 0 then
notice "Failed to ReAllocate hRDataLenBuff! ERROR: "; GetLastError()
ret = ShutDown()
end if
else
hRDataLenBuff = GlobalAlloc( Cols * 8 )
if hRDataLenBuff = 0 then
notice "Failed to Allocate hRDataLenBuff"
ret = ShutDown()
end if
end if
hRDataLenBuffPtr = GlobalLock( hRDataLenBuff )
if hRDataLenBuffPtr = 0 then
notice "Failed to Obtain Poiner to Memory address for hRDataLenBuff!"
ret = ShutDown()
end if
hResult = GlobalAlloc( maxBytes )
' notice "Allocated ";(maxBytes);" bytes..."
hResultPtr = GlobalLock ( hResult )
'"Starting hResultPtr address: "; hResultPtr
hResultPtrBak = hResultPtr
TargetValuePtr = mPtr
RunningTot = 0
[SQLFetch] '<< FETCH!
Rows = 0
hResultPtr2 = hResultPtr
hRDataLenBuffPtr2 = hDataLenBuffPtr
do
calldll #odbc, "SQLFetch",_
hStmt as ULong,_
FetchRet as Short
if FetchRet <> SQL.NO.DATA.FOUND(1) then
dbOut.struct = strLenPtr
TargetValuePtr = mPtr
for k = 1 to Cols
NEWstrLenPtr = strLenPtr + ((k - 1) * 4)
dbOut.struct = NEWstrLenPtr
strLen = dbOut.size.struct
NEWhDataLenBuffPtr = hDataLenBuffPtr + ((k - 1) * 4) 'didn't have the "r"
dbOut2.struct = NEWhDataLenBuffPtr
TargetInc = dbOut2.size.struct
if ( strLen <> SQL.NULL.DATA(1) ) then
calldll #kernel32, "RtlMoveMemory",_
hRDataLenBuffPtr as ULong,_
NEWstrLenPtr as ULong,_
4 as Long,_
Ret as Void
x = (hRDataLenBuffPtr + 4)
dbOut.size.struct = RunningTot
calldll #kernel32, "RtlMoveMemory",_
x as ULong,_
dbOut as Struct,_
4 as Long,_
Ret as Void
dbOut2.struct = hRDataLenBuffPtr
calldll #kernel32, "RtlMoveMemory",_
hResultPtr2 as ULong,_
TargetValuePtr as ULong,_
strLen as Long,_
Ret as Void
else
strLen = 0
dbOut.size.struct = 0
dbOut2.size.struct = 0
calldll #kernel32, "RtlMoveMemory",_
hRDataLenBuffPtr as ULong,_
dbOut as Struct,_
4 as Long,_
Ret as Void
x = hRDataLenBuffPtr + 4
dbOut.size.struct = 0
calldll #kernel32, "RtlMoveMemory",_
x as ULong,_
dbOut as Struct,_
4 as Long,_
Ret as Void
end if
TargetValuePtr = TargetValuePtr + TargetInc 'strLen
RunningTot = RunningTot + strLen
hResultPtr2 = hResultPtr + RunningTot
hRDataLenBuffPtr = hRDataLenBuffPtr + 8
wasTot = wasTot + TargetInc
next k
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
if (FetchRet = SQL.SUCCESS(1)) or (FetchRet = SQL.SUCCESS.WITH.INFO(1)) then
Rows = Rows + 1
Ret = GlobalUnlock ( hResult )
hResult = GlobalReAlloc( hResult, (RunningTot + maxBytes) )
if hResult = 0 then
notice "ReAlloc hResult Failed! Trying to Alloc: "; (RunningTot + maxBytes);" bytes. Error: "; GetLastError()
ret = ShutDown()
end if
hResultPtr = GlobalLock( hResult )
hResultPtr2 = hResultPtr + RunningTot
Ret = GlobalUnlock ( hRDataLenBuff )
hRDataLenBuff = GlobalReAlloc( hRDataLenBuff, ((Cols * 8) * (Rows+1)) )
if hRDataLenBuff = 0 then
notice "ReAlloc hRDataLenBuff Failed! Trying to Alloc: "; ((Cols * 8) * (Rows+1));" bytes. Error: "; GetLastError()
ret = ShutDown()
end if
hRDataLenBuffPtr = GlobalLock( hRDataLenBuff )
hRDataLenBuffPtr = hRDataLenBuffPtr + (((Cols) * 8) * (Rows))
end if
end if
loop until ((FetchRet <> SQL.SUCCESS(1)) and (FetchRet <> SQL.SUCCESS.WITH.INFO(1)) or (FetchRet = SQL.NO.DATA.FOUND(1)))
if FetchRet = SQL.ERROR(1) then
ret = getbacktalk(SQL.HANDLE.STMT(1), hStmt, 1)
input "";a$
end if
if GlobalUnlock( hRDataLenBuff ) <> 0 then
notice "Failed to UnLock hRDataLenBuff! ERROR: "; GetLastError()
ret = ShutDown()
end if
ret = GlobalUnlock( hResult )
if ret <> 0 then
notice "Failed to UnLock hResult! ERROR: "; GetLastError(); " Returned: ";ret
ret = ShutDown()
end if
if setdbdata(dbName$, "Rows", str$(Rows)) <> 0 then
notice "Failed to Set number of Rows!"
ret = ShutDown
end if
if setdbdata(dbName$, "hResult", str$(hResult)) <> 0 then
notice "Failed to Set hResult!"
ret = ShutDown
end if
if setdbdata(dbName$, "hRDataLenBuff", str$(hRDataLenBuff)) <> 0 then
notice "Failed to Set hDataLenBuff!"
ret = ShutDown
end if
Ret = GlobalFree( hMem )
Ret = GlobalFree( hstrLenBuff )
Ret = GlobalFree( hDataLenBuff )
[SQLFreeStmt]
SC = SQL.CLOSE
calldll #odbc, "SQLFreeStmt",_
hStmt as ULong,_
SC as Long,_
Ret as Short
if Ret <> SQL.SUCCESS(1) then
err = getbacktalk(SQL.HANDLE.STMT(1), hStmt, 1)
if Ret = SQL.ERROR(1) then
ret = ShutDown()
end if
else
ret = setdbdata(dbName$, "hStmt", "0")
end if
end function
'ODBC with Liberty BASIC
'Copyright © Dennis McKinney 2004
'DSNless version.
'This demo connects to the database using SQLDriverConnect.
'A Data Source Name is not required.
'Very basic routines to demonstrate that Access and VB databases
'can be used with Liberty BASIC V3.+ through ODBC.
' FOR DEMONSTRATION PURPOSES ONLY
' SYSTEM REQUIREMENTS:
' MDAC 2.1 or greater
' Microsoft Jet
'Keywords for different Access & VB database versions,
'Support depends on your MDAC version:
'CREATE_DBV2, prior to Access97
'CREATE_DBV3, Access97
'CREATE_DBV4, Access 2000
'CREATE_DB, creates a version to match the
'MDAC (Microsoft Data Access Components)
'installed on the computer.
DbVerKeyword$ = "CREATE_DBV3"
Driver$ = "Microsoft Access Driver (*.MDB)"
'** Globals
gTmpTable$(0) = "" 'temporary array for table names
gTable$(0) = "" 'array for table names
dim gColname$(0) 'for 1 recordset column names
dim gRowset$(1,1) 'for 1 recordset row values
dim gColRow(2) 'for 1 recordset row & col count
struct gHandle, h as long 'for ODBC handles
struct NativeErrorPtr, errcode as long 'for error handler
struct TextLengthPtr, length as short
struct ColumnCountPtr, count as long 'for GetColumns
struct NumAttPtr, value as short
'** end Globals
UpperLeftX=int((DisplayWidth-WindowWidth)/2)
UpperLeftY=int((DisplayHeight-WindowHeight)/2)
menu #main, "&File", "E&xit", [Quit]
menu #main, "&Database", "&New Database", [CreateDatabase], _
"&Open Database", [OpenDatabase], "&Close", [CloseDatabase]
menu #main, "&Table", "&Create 1 Test Table", [CreateTable], _
"&Delete Test Table", [DeleteTable]
menu #main, "&Records", "&Add Sample Record", [AddSampleRecord], _
"R&ead Records", [ReadRecords], _
"&Delete John Smith Record", [DeleteJohnSmith]
txt$ = "Steps:"+chr$(10)+"1: Create a database (one time)"+chr$(10)
txt$ = txt$+"2: Open that database"+chr$(10)
txt$ = txt$+"3: Create a table"+chr$(10)
txt$ = txt$+"4: Add a record"+chr$(10)
txt$ = txt$+"5: Experiment"+chr$(10)
txt$ = txt$+"6: Close the database"
statictext #main, txt$,10,50,200,200
open "ODBC Test 1" for window as #main
#main, "trapclose [Quit]"
Open "odbc32.dll" for dll as #odbc
[loop]
wait
[Quit]
'every database opened must be closed
If hDb1 > 0 then
ret = CloseDatabase(hDb1)
End if
'every workspace opened must be closed
hWksp1 = CloseWorkspace(hWksp1)
Close #odbc: close #main
end
[CreateDatabase]
filedialog "Create New Database"+space$(200)+"save", "*.mdb", DbPath$
Attributes$ = DbVerKeyword$+"="+chr$(34)+DbPath$+chr$(34)
If lower$(right$(DbPath$,4)) <> ".mdb" then
If DbPath$ = "" then
'nothing
Else
Notice "Invalid Database Type"+chr$(13)+"File extension must be *.mdb"
End if
Else
ret = CreateDatabase(Driver$,Attributes$)
End if
goto [loop]
[OpenDatabase]
If hDb1 = 0 then
filedialog "Open Database", "*.mdb", DbPath$
If lower$(right$(DbPath$,4)) <> ".mdb" then
If DbPath$ = "" then
'nothing
Else
Notice "Invalid Database Type"+chr$(13)+"File extension must be *.mdb"
End if
Else
hWksp1 = OpenWorkspace() 'or Environment
hDb1 = OpenDatabase(hWksp1,Driver$,DbPath$,Uid$,Pwd$)
End if
Else
Notice "Database already open."
End if
goto [loop]
[CloseDatabase]
hDb1 = CloseDatabase(hDb1)
goto [loop]
[CreateTable]
If hDb1 > 0 then
SQL$ = "CREATE TABLE TestTable"
SQL$ = SQL$ + " (ID counter, LastName text(30), FirstName text(25),"
SQL$ = SQL$ + " SSN text(11), Notes text(255));"
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
End if
goto [loop]
[AddSampleRecord]
If hDb1 > 0 then
SQL$ = "INSERT INTO TestTable (LastName, FirstName, SSN, Notes)"
SQL$ = SQL$ + " VALUES('Smith', 'John', '123-45-6789', 'Good Programmer');"
Cursor hourglass
hStmt = GetStmtHandle(hDb1)
for i = 1 to 200
ret = RunSQL(hStmt, SQL$)
If ret = 0 then exit for
next i
Call FreeStatement hStmt
Cursor Normal
End if
goto [loop]
[ReadRecords]
If hDb1 > 0 then
Cursor hourglass
SQL$ = "SELECT ID, FirstName, LastName, SSN, Notes"
SQL$ = SQL$ + " FROM TestTable;"
ret = OpenRecordset(hDb1,SQL$)
cls
If ret <> 0 then
for i = 1 to gColRow(1)
print gColname$(i)+space$(16-len(gColname$(i)));
next i
End If
print
print
for i = 1 to gColRow(2)
for j = 1 to gColRow(1)
print gRowset$(i,j)+space$(16-len(gRowset$(i,j)));
next j
print " "
next i
Cursor normal
End if
goto [loop]
[DeleteTable]
If hDb1 > 0 then
SQL$ = "DROP TABLE TestTable"
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
End if
goto [loop]
[DeleteJohnSmith]
If hDb1 > 0 then
SQL$ = "DELETE * FROM TestTable WHERE FirstName = 'John'"
SQL$ = SQL$ + " AND LastName = 'Smith';"
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
End if
goto [loop]
'*********************** SUBS & FUNCTIONS ******************************
Function OpenRecordset(hDb,SQL$)
SQL.NO.DATA = 100
hStmt = GetStmtHandle(hDb)
ret = RunSQL(hStmt, SQL$)
if ret <> 0 then cols = GetColumnCount(hStmt)
if cols > 0 then 'a recordset was created
Redim gColname$(cols)
For i = 1 to cols
gColname$(i) = GetColNames$(hStmt,i)
Next i
Redim gRowset$(10000,cols)
'move to the first row of the result set
calldll #odbc,"SQLFetch",hStmt as long,ret as short
i = 1
While ret <> SQL.NO.DATA
For j = 1 to cols
gRowset$(i,j) = GetColData$(hDb,hStmt,j)
Next j
i = i + 1
calldll #odbc,"SQLFetch",hStmt as long,ret as short
If i > 9999 then Exit While
Wend
'store col & row count
gColRow(1) = cols
gColRow(2) = i-1
OpenRecordset = 1 'success
else
OpenRecordset = 0 'fail
end if
calldll #odbc,"SQLCloseCursor",hStmt as long,ret as short
Call FreeStatement hStmt
End Function
Function GetColData$(hDb,hStmt,ColNum)
SQLState$ = space$(5) + chr$(0)
MessageText$ = space$(256) + chr$(0)
SQL.Char = 1
SQL.SUCCESS = 0
SQL.SUCCESS.WITH.INFO = 1
SQL.NO.DATA = 100
SQL.ERROR = -1
'To test the handling of truncated data use
'Buffer$ = Space$(10)
Buffer$ = Space$(512)
Buflen = len(Buffer$)
While ret <> SQL.NO.DATA
calldll #odbc,"SQLGetData",hStmt as long,ColNum as short, _
SQL.Char as short,Buffer$ as ptr, Buflen as short, _
TextLengthPtr as ptr,ret as short
Select case ret
case SQL.SUCCESS
GetColData$ = GetColData$ + _
left$(Buffer$, TextLengthPtr.length.struct)
case SQL.ERROR
GetColData$ = ""
Exit While
case SQL.SUCCESS.WITH.INFO
calldll #odbc,"SQLGetDiagRec",3 as short,hStmt as long, _
1 as short,SQLState$ as ptr,NativeErrorPtr as ptr, _
MessageText$ as ptr,256 as short,TextLengthPtr as ptr, _
ret as short
If left$(SQLState$,5) = "01004" then
GetColData$ = GetColData$ + _
left$(Buffer$,instr(Buffer$,chr$(0))-1)
End if
End select
Wend
End Function
Function GetColNames$(hStmt,ColNum)
SQL.COLUMN.LABEL = 18
Buffer$ = Space$(256) + chr$(0)
calldll #odbc,"SQLColAttribute",hStmt as long,ColNum as short, _
SQL.COLUMN.LABEL as short,Buffer$ as ptr,255 as short, _
TextLengthPtr as ptr,NumAttPtr as ptr,ret as short
GetColNames$ = left$(Buffer$, TextLengthPtr.length.struct)
End Function
Function GetColumnCount(hStmt)
'In: statement handle.
'Out: number of columns in result set, if any.
'0 if error or no result set was created.
SQL.SUCCESS = 0
SQL.STILL.EXECUTING = 2
ColumnCountPtr.count.struct = 0
ret = SQL.STILL.EXECUTING
While ret = SQL.STILL.EXECUTING
calldll #odbc,"SQLNumResultCols",hStmt as long, _
ColumnCountPtr as ptr,ret as short
Select Case ret
case SQL.STILL.EXECUTING
case SQL.SUCCESS
GetColumnCount = ColumnCountPtr.count.struct
case Else
Call ErrMsg 3,hStmt
GetColumnCount = 0
End Select
Wend
End Function
Function CreateDatabase(Driver$,Attributes$)
open "odbccp32.dll" for dll as #odbccp32
calldll #odbccp32,"SQLConfigDataSource",0 as long,1 as short, _
Driver$ as ptr,Attributes$ as ptr,ret as boolean
close #odbccp32
If ret = 0 Then
Notice "Create Database Error"+chr$(13)+"Failed to create database"
End If
CreateDatabase = ret
End Function
Function GetTables(InputHandle)
'Purpose: fill gTable$ array with table names
'In: database connection handle
'Out: number of table names added to gTable$ array
Redim gTmpTable$(10000)
struct LenRead, val as long
struct OutputHandlePtr, handle as long
SQL.NO.DATA = 100
SQL.HANDLE.STMT = 3
TableName$ = Space$(256) + chr$(0)
TableType$ = "'TABLE'" + chr$(0)
lenTableType = Len(TableType$)
calldll #odbc, "SQLAllocHandle",SQL.HANDLE.STMT as short, _
InputHandle as long,OutputHandlePtr as ptr,ret as short
If ret <> 0 then
GetTables = 0
goto [exitGetTables]
End If
hStmt = OutputHandlePtr.handle.struct
calldll #odbc, "SQLTables",hStmt as long,0 as short,-3 as short, _
0 as short,-3 as short,0 as short,-3 as short,TableType$ as ptr, _
lenTableType as short,ret as short
If ret <> 0 then
Call ErrMsg 3,hStmt
GetTables = 0
goto [exitGetTables]
End If
calldll #odbc,"SQLFetch",hStmt as long,ret as short
If ret <> 0 then
GetTables = 0
goto [exitGetTables]
End If
count = 0
While intRc <> SQL.NO.DATA
calldll #odbc,"SQLGetData",hStmt as long,3 as short,1 as short, _
TableName$ as ptr,255 as short,LenRead as ptr,intRc as short
TableName$ = left$(TableName$,LenRead.val.struct)
gTmpTable$(count) = TableName$
count = count + 1
TableName$ = Space$(256) + chr$(0)
calldll #odbc,"SQLFetch",hStmt as long,intRc as short
Wend
Redim gTable$(count)
For i = 0 to count-1
gTable$(i) = gTmpTable$(i)
next i
Redim gTmpTable$(0)
GetTables = count
[exitGetTables]
Call FreeStatement hStmt
End Function
Function OpenWorkspace()
'Out: Workspace (environment) handle.
gHandle.h.struct = 0
calldll #odbc,"SQLAllocHandle",1 as short,0 as long,gHandle as ptr, _
ret as short
hEnv = gHandle.h.struct
ver3 = 3 'use ODBC 3
calldll #odbc,"SQLSetEnvAttr",hEnv as long,200 as long,ver3 as long, _
0 as long,ret as short
OpenWorkspace = hEnv
End Function
Function CloseWorkspace(hWorkspace)
calldll #odbc,"SQLFreeHandle",1 as short,hWorkspace as long,ret as short
CloseWorkspace = ret
End Function
Function OpenDatabase(WorkSpace,Driver$,DbPath$,Uid$,Pwd$)
'In: Workspace/environment handle, datasource path,
'optional user ID, optional password.
'Out: database connection handle, 0 if failed.
gHandle.h.struct = 0
calldll #odbc,"SQLAllocHandle",2 as short,WorkSpace as long, _
gHandle as ptr,ret as short
hCon = gHandle.h.struct
connstr$ = "Dbq=" + DbPath$ + ";" + _
"Driver={" + Driver$ + "};" + _
"Uid=" + Uid$ + ";Pwd=" +Pwd$
outConnStr$ = space$(1024)
Lconnstr = len(connstr$)
struct cbStrLen, x as long
calldll #odbc,"SQLDriverConnect", hCon as ulong, 0 as long, connstr$ as ptr, _
Lconnstr as short, outConnStr$ as ptr, 1024 as short, cbStrLen as ptr, _
0 as short, ret as long
IF ret <> 0 then
Call ErrMsg 2,hCon
hCon = CloseDatabase(hCon)
End IF
OpenDatabase = hCon
End Function
Function CloseDatabase(hDb)
'In: database connection handle.
'Out: 0 if successful, >0 if failed.
calldll #odbc,"SQLDisconnect",hDb as long,ret as short
calldll #odbc,"SQLFreeHandle",2 as short,hDb as long,ret as short
IF ret <> 0 then Call ErrMsg 2,hDb
CloseDatabase = ret
End Function
Function GetStmtHandle(hDBC)
gHandle.h.struct = 0
calldll #odbc,"SQLAllocHandle",3 as short,hDBC as long, _
gHandle as ptr, ret as short
hStmt = gHandle.h.struct
GetStmtHandle = hStmt
End Function
Function RunSQL(hStmt,strSQL$)
'In: database connection handle, SQL statement to execute.
'Out: 0 if failed, statement handle if successful.
SQL.STILL.EXECUTING = 2
lenStmt = len(strSQL$)
ret = SQL.STILL.EXECUTING
While ret = SQL.STILL.EXECUTING
calldll #odbc, "SQLExecDirect",hStmt as long,strSQL$ as ptr,_
lenStmt as short,ret as short
Wend
If ret <> 0 then
Call ErrMsg 3,hStmt
RunSQL = 0
goto [exitRunSQL]
End If
RunSQL = hStmt
[exitRunSQL]
End Function
Sub FreeStatement hStmt
calldll #odbc,"SQLFreeHandle",3 as short,hStmt as long,ret as short
End Sub
Sub ErrMsg hType,Hndl
SQLState$ = space$(5) + chr$(0)
MessageText$ = space$(256) + chr$(0)
calldll #odbc,"SQLGetDiagRec",hType as short,Hndl as long, _
1 as short,SQLState$ as ptr,NativeErrorPtr as ptr, _
MessageText$ as ptr,256 as short,TextLengthPtr as ptr,ret as short
i = i + 1
msg$ = "SQLState Code: "+left$(SQLState$,5)+chr$(10)
msg$=msg$+"Native Error: "+str$(NativeErrorPtr.errcode.struct)+chr$(10)
msg$=msg$+left$(MessageText$,TextLengthPtr.length.struct)
If msg$ <> "" Then
Notice "LB ODBC Error"+chr$(13)+msg$
Else
Notice "LB ODBC Error"+chr$(13)+"An unKnown error occured. Check your code."
End if
End Sub
|
|
|
|
Post by metro on Oct 12, 2018 2:13:23 GMT -5
maybe more helpful I grabbed the Dll from HERE
I then dropped it into the Folder with the code below, I didn't trust the installer that came with it the code below functions
'MySQL usage with ODBC on Liberty BASIC
'Copyright (c) 2005, Verisoft, Onur Alver
'Credit: Based on Dennis McKinney's DSNless ODBC Demo Example
'
' SYSTEM REQUIREMENTS:
' MySQL 3.51
' MyLibertyDB Database must already exist, create this with MySQL Command Line Client
Driver$ = "ODBC"
'** Globals
gTmpTable$(0) = "" 'temporary array for table names
gTable$(0) = "" 'array for table names
dim gColname$(0) 'for 1 recordset column names
dim gRowset$(1,1) 'for 1 recordset row values
dim gColRow(2) 'for 1 recordset row & col count
struct gHandle, h as long 'for ODBC handles
struct NativeErrorPtr, errcode as long 'for error handler
struct TextLengthPtr, length as short
struct ColumnCountPtr, count as long 'for GetColumns
struct NumAttPtr, value as short
Global hWnd
Global GlobalCtr
GlobalCtr=0
'** end Globals
UpperLeftX=100
UpperLeftY=100
WindowWidth = 800
WindowHeight =580
nomainwin
texteditor #main.te, 0, 0, 790, 530
UpperLeftX=int((DisplayWidth-WindowWidth)/2)
UpperLeftY=int((DisplayHeight-WindowHeight)/2)
menu #main, "&File", "E&xit", [Quit]
menu #main, "Edit"
menu #main, "&Database", "&New Database", [CreateDatabase], _
"&Open Database", [OpenDatabase], "&Close", [CloseDatabase]
menu #main, "&Table", "&Create 1 Test Table", [CreateTable], _
"&Drop Test Table", [DeleteTable]
menu #main, "&Records", "&Add 200 Random Records", [AddSampleRecord], _
"R&ead Records", [ReadRecords], _
"&Delete John Strong Record(s)", [DeleteJohnStrong]
menu #main, "&Help", "About", [About],"Tutorial", [Tutorial]
txt$ = "Steps:"+chr$(10)+"1: Create MyLibertyDB (one time) with MySQL Command Line Client"+chr$(10)
txt$ = txt$+"2: Open MyLibertyDB database"+chr$(10)
txt$ = txt$+"3: Create a table"+chr$(10)
txt$ = txt$+"4: Add a record"+chr$(10)
txt$ = txt$+"5: Experiment"+chr$(10)
txt$ = txt$+"6: Close the database"
'statictext #main, txt$,10,50,200,200
open "MySQL ODBC Demo" for window as #main
#main, "trapclose [Quit]"
#main.te, "!autoresize"; 'Tell the texteditor to resize with the terminal window"
#main, "font fixedsys 10";
hWnd=hwnd(#main)
Open "myodbc3.dll" for dll as #odbc
[loop]
wait
[Quit]
'every database opened must be closed
If hDb1 > 0 then
ret = CloseDatabase(hDb1)
End if
'every workspace opened must be closed
hWksp1 = CloseWorkspace(hWksp1)
Close #odbc: close #main
end
[About]
Notice "About Liberty MySQL Demo"+chr$(13)+"Verisoft MySQL ODBC Demo"+chr$(13)+"Version 1.00"+chr$(13)+"Verisoft, Copyright (c) 2005"+chr$(13)+"www.verisoft.com"+chr$(13)+"Based on Dennis McKinney's DSNless ODBC Demo"
goto [loop]
[Tutorial]
Notice "Liberty MySQL Tutorial"+chr$(13)+txt$
goto [loop]
[CreateDatabase]
Notice "Create Database First !"+chr$(13)+"Use MySQL Command Line Client"+chr$(13)+"to create MyLibertyDB Database !"
goto [loop]
[OpenDatabase]
Cursor hourglass
If hDb1 = 0 then
hWksp1 = OpenWorkspace() 'or Environment
hDb1 = OpenDatabase(hWksp1,Driver$,DbPath$,Uid$,Pwd$)
Else
Notice "Database already open."
End if
Notice "DB Handle:";STR$(hDb1)
Cursor normal
goto [loop]
[CloseDatabase]
hDb1 = CloseDatabase(hDb1)
goto [loop]
[CreateTable]
Cursor hourglass
t1=time$("ms")
If hDb1 > 0 then
SQL$ = "CREATE TABLE TestTable"
SQL$ = SQL$ + " (ID int, LastName varchar(20), FirstName varchar(20),"
SQL$ = SQL$ + " SSN varchar(20), Notes varchar(255) );"
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
t2=time$("ms")
Notice "MS SQLServer Table Create Performance"+chr$(13)+"Table created in "+str$(t2-t1)+" milliseconds"
End if
Cursor normal
goto [loop]
[AddSampleRecord]
If hDb1 > 0 then
t1=time$("ms")
for i = 1 to 200
sName$=word$("Mary Michael Greg James John Alice Susan George David Roger",1+int(rnd(1)*9))
sSurname$=word$("Stone Strong Wood Smith Doe Wonder Farmer Smart Lion Chainer",1+int(rnd(1)*9))
sSSN$=left$( str$( 100+int(rnd(1)*999) ), 3 ) + "-" + left$( str$( 10+int(rnd(1)*99)),2 ) + "-"+ left$(str$(1000+int(rnd(1)*9999)),4)
sNotes$=word$("Good-Programmer Great-Programmer www.verisoft.com-programmer Marvelous-Programmer Exceptional-Programmer Spectacular-Programmer Fine-Programmer Wonderful-Programmer Super-Programmer Wizard-Programmer",1+int(rnd(1)*9))
GlobalCtr=GlobalCtr+1
IDCTR$="'"+STR$(GlobalCtr)+"' "
SQL$ = "INSERT INTO TestTable (ID, LastName, FirstName, SSN, Notes)"
SQL$ = SQL$ + " VALUES(";IDCTR$;",'"+sSurname$+"','"+sName$+"','"+sSSN$+"','"+sNotes$+"');"
Cursor hourglass
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
If ret = 0 then exit for
next i
t2=time$("ms")
Notice "MySQL Insert Performance"+chr$(13)+"200 records inserted in "+str$(t2-t1)+" milliseconds"
Cursor Normal
End if
goto [loop]
[ReadRecords]
NoRecs=0
If hDb1 > 0 then
t1=time$("ms")
Cursor hourglass
SQL$ = "SELECT ID, FirstName, LastName, SSN, Notes"
SQL$ = SQL$ + " FROM TestTable;"
ret = OpenRecordset(hDb1,SQL$)
t2=time$("ms")
Notice "MySQL Select Performance"+chr$(13)+str$(gColRow(2))+" records selected in "+str$(t2-t1)+" milliseconds"
print #main.te,"---------------------------------------------------------------------------------------- "
If ret <> 0 then
for i = 1 to gColRow(1)
print #main.te,gColname$(i)+space$(16-len(gColname$(i)));
next i
End If
print #main.te,""
print #main.te,"---------------------------------------------------------------------------------------- "
for i = 1 to gColRow(2)
for j = 1 to gColRow(1)
print #main.te,gRowset$(i,j)+space$(16-len(gRowset$(i,j)));
next j
print #main.te," "
NoRecs=NoRecs+1
next i
print #main.te,"---------------------------------------------------------------------------------------- "
print #main.te,"Number records read = ";NoRecs
Cursor normal
End if
goto [loop]
[DeleteTable]
Cursor hourglass
t1=time$("ms")
If hDb1 > 0 then
SQL$ = "DROP TABLE TestTable"
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
End if
t2=time$("ms")
Notice "MySQL Drop Table Performance"+chr$(13)+"Table dropped in "+str$(t2-t1)+" milliseconds"
Cursor normal
goto [loop]
[DeleteJohnStrong]
t1=time$("ms")
Cursor hourglass
If hDb1 > 0 then
SQL$ = "DELETE FROM TestTable WHERE FirstName Like 'John%'"
SQL$ = SQL$ + " AND LastName Like 'Strong%';"
hStmt = GetStmtHandle(hDb1)
ret = RunSQL(hStmt, SQL$)
Call FreeStatement hStmt
End if
t2=time$("ms")
Notice "MySQL Delete Performance"+chr$(13)+"Record(s) deleted in "+str$(t2-t1)+" milliseconds"
Cursor normal
goto [loop]
'*********************** SUBS & FUNCTIONS ******************************
Function OpenRecordset(hDb,SQL$)
SQL.NO.DATA = 100
hStmt = GetStmtHandle(hDb)
ret = RunSQL(hStmt, SQL$)
if ret <> 0 then cols = GetColumnCount(hStmt)
if cols > 0 then 'a recordset was created
Redim gColname$(cols)
For i = 1 to cols
gColname$(i) = GetColNames$(hStmt,i)
Next i
Redim gRowset$(10000,cols)
'move to the first row of the result set
calldll #odbc,"SQLFetch",hStmt as long,ret as short
i = 1
While ret <> SQL.NO.DATA
For j = 1 to cols
gRowset$(i,j) = GetColData$(hDb,hStmt,j)
Next j
i = i + 1
calldll #odbc,"SQLFetch",hStmt as long,ret as short
If i > 9999 then Exit While
Wend
'store col & row count
gColRow(1) = cols
gColRow(2) = i-1
OpenRecordset = 1 'success
else
OpenRecordset = 0 'fail
end if
calldll #odbc,"SQLCloseCursor",hStmt as long,ret as short
Call FreeStatement hStmt
End Function
Function GetColData$(hDb,hStmt,ColNum)
SQLState$ = space$(5) + chr$(0)
MessageText$ = space$(256) + chr$(0)
SQL.Char = 1
SQL.SUCCESS = 0
SQL.SUCCESS.WITH.INFO = 1
SQL.NO.DATA = 100
SQL.ERROR = -1
'To test the handling of truncated data use
'Buffer$ = Space$(10)
Buffer$ = Space$(512)
Buflen = len(Buffer$)
While ret <> SQL.NO.DATA
calldll #odbc,"SQLGetData",hStmt as long,ColNum as short, _
SQL.Char as short,Buffer$ as ptr, Buflen as short, _
TextLengthPtr as ptr,ret as short
Select case ret
case SQL.SUCCESS
GetColData$ = GetColData$ + _
left$(Buffer$, TextLengthPtr.length.struct)
case SQL.ERROR
GetColData$ = ""
Exit While
case SQL.SUCCESS.WITH.INFO
calldll #odbc,"SQLGetDiagRec",3 as short,hStmt as long, _
1 as short,SQLState$ as ptr,NativeErrorPtr as ptr, _
MessageText$ as ptr,256 as short,TextLengthPtr as ptr, _
ret as short
If left$(SQLState$,5) = "01004" then
GetColData$ = GetColData$ + _
left$(Buffer$,instr(Buffer$,chr$(0))-1)
End if
End select
Wend
End Function
Function GetColNames$(hStmt,ColNum)
SQL.COLUMN.LABEL = 18
Buffer$ = Space$(256) + chr$(0)
calldll #odbc,"SQLColAttribute",hStmt as long,ColNum as short, _
SQL.COLUMN.LABEL as short,Buffer$ as ptr,255 as short, _
TextLengthPtr as ptr,NumAttPtr as ptr,ret as short
GetColNames$ = left$(Buffer$, TextLengthPtr.length.struct)
End Function
Function GetColumnCount(hStmt)
'In: statement handle.
'Out: number of columns in result set, if any.
'0 if error or no result set was created.
SQL.SUCCESS = 0
SQL.STILL.EXECUTING = 2
ColumnCountPtr.count.struct = 0
ret = SQL.STILL.EXECUTING
While ret = SQL.STILL.EXECUTING
calldll #odbc,"SQLNumResultCols",hStmt as long, _
ColumnCountPtr as ptr,ret as short
Select Case ret
case SQL.STILL.EXECUTING
case SQL.SUCCESS
GetColumnCount = ColumnCountPtr.count.struct
case Else
Call ErrMsg 3,hStmt
GetColumnCount = 0
End Select
Wend
End Function
Function CreateDatabase(Driver$,Attributes$)
open "odbccp32.dll" for dll as #odbccp32
calldll #odbccp32,"SQLConfigDataSource",0 as long,1 as short, _
Driver$ as ptr,Attributes$ as ptr,ret as boolean
close #odbccp32
If ret = 0 Then
Notice "Create Database Error"+chr$(13)+"Failed to create database"
End If
CreateDatabase = ret
End Function
Function GetTables(InputHandle)
'Purpose: fill gTable$ array with table names
'In: database connection handle
'Out: number of table names added to gTable$ array
Redim gTmpTable$(10000)
struct LenRead, val as long
struct OutputHandlePtr, handle as long
SQL.NO.DATA = 100
SQL.HANDLE.STMT = 3
TableName$ = Space$(256) + chr$(0)
TableType$ = "'TABLE'" + chr$(0)
lenTableType = Len(TableType$)
calldll #odbc, "SQLAllocHandle",SQL.HANDLE.STMT as short, _
InputHandle as long,OutputHandlePtr as ptr,ret as short
If ret <> 0 then
GetTables = 0
goto [exitGetTables]
End If
hStmt = OutputHandlePtr.handle.struct
calldll #odbc, "SQLTables",hStmt as long,0 as short,-3 as short, _
0 as short,-3 as short,0 as short,-3 as short,TableType$ as ptr, _
lenTableType as short,ret as short
If ret <> 0 then
Call ErrMsg 3,hStmt
GetTables = 0
goto [exitGetTables]
End If
calldll #odbc,"SQLFetch",hStmt as long,ret as short
If ret <> 0 then
GetTables = 0
goto [exitGetTables]
End If
count = 0
While intRc <> SQL.NO.DATA
calldll #odbc,"SQLGetData",hStmt as long,3 as short,1 as short, _
TableName$ as ptr,255 as short,LenRead as ptr,intRc as short
TableName$ = left$(TableName$,LenRead.val.struct)
gTmpTable$(count) = TableName$
count = count + 1
TableName$ = Space$(256) + chr$(0)
calldll #odbc,"SQLFetch",hStmt as long,intRc as short
Wend
Redim gTable$(count)
For i = 0 to count-1
gTable$(i) = gTmpTable$(i)
next i
Redim gTmpTable$(0)
GetTables = count
[exitGetTables]
Call FreeStatement hStmt
End Function
Function OpenWorkspace()
'Out: Workspace (environment) handle.
gHandle.h.struct = 0
calldll #odbc,"SQLAllocHandle",1 as short,0 as long,gHandle as ptr, _
ret as short
hEnv = gHandle.h.struct
ver3 = 3 'use ODBC 3
calldll #odbc,"SQLSetEnvAttr",hEnv as long,200 as long,ver3 as long, _
0 as long,ret as short
OpenWorkspace = hEnv
End Function
Function CloseWorkspace(hWorkspace)
calldll #odbc,"SQLFreeHandle",1 as short,hWorkspace as long,ret as short
CloseWorkspace = ret
End Function
Function OpenDatabase(WorkSpace,Driver$,DbPath$,Uid$,Pwd$)
'In: Workspace/environment handle, datasource path,
'optional user ID, optional password.
'Out: database connection handle, 0 if failed.
gHandle.h.struct = 0
calldll #odbc,"SQLAllocHandle",2 as short,WorkSpace as long, _
gHandle as ptr,ret as short
hCon = gHandle.h.struct
connstr$ ="Driver={MySQL ODBC 3.51 Driver}; Server=localhost;PORT=3306; Database=mylibertydb; UID=root; PWD=sa; OPTION=3 "
outConnStr$ = space$(1024)
Lconnstr = len(connstr$)
struct cbStrLen, x as long
calldll #odbc,"SQLDriverConnect", hCon as ulong, 0 as long, connstr$ as ptr, _
Lconnstr as short, outConnStr$ as ptr, 1024 as short, cbStrLen as ptr, _
0 as short, ret as long
IF ret <> 0 then
Call ErrMsg 2,hCon
hCon = CloseDatabase(hCon)
End IF
OpenDatabase = hCon
End Function
Function CloseDatabase(hDb)
'In: database connection handle.
'Out: 0 if successful, >0 if failed.
calldll #odbc,"SQLDisconnect",hDb as long,ret as short
calldll #odbc,"SQLFreeHandle",2 as short,hDb as long,ret as short
IF ret <> 0 then Call ErrMsg 2,hDb
CloseDatabase = ret
End Function
Function GetStmtHandle(hDBC)
gHandle.h.struct = 0
calldll #odbc,"SQLAllocHandle",3 as short,hDBC as long, _
gHandle as ptr, ret as short
hStmt = gHandle.h.struct
GetStmtHandle = hStmt
End Function
Function RunSQL(hStmt,strSQL$)
'In: database connection handle, SQL statement to execute.
'Out: 0 if failed, statement handle if successful.
SQL.STILL.EXECUTING = 2
lenStmt = len(strSQL$)
ret = SQL.STILL.EXECUTING
While ret = SQL.STILL.EXECUTING
calldll #odbc, "SQLExecDirect",hStmt as long,strSQL$ as ptr,_
lenStmt as short,ret as short
Wend
If ret <> 0 then
Call ErrMsg 3,hStmt
RunSQL = 0
goto [exitRunSQL]
End If
RunSQL = hStmt
[exitRunSQL]
End Function
Sub FreeStatement hStmt
calldll #odbc,"SQLFreeHandle",3 as short,hStmt as long,ret as short
End Sub
Sub ErrMsg hType,Hndl
SQLState$ = space$(5) + chr$(0)
MessageText$ = space$(256) + chr$(0)
calldll #odbc,"SQLGetDiagRec",hType as short,Hndl as long, _
1 as short,SQLState$ as ptr,NativeErrorPtr as ptr, _
MessageText$ as ptr,256 as short,TextLengthPtr as ptr,ret as short
i = i + 1
msg$ = "SQLState Code: "+left$(SQLState$,5)+chr$(10)
msg$=msg$+"Native Error: "+str$(NativeErrorPtr.errcode.struct)+chr$(10)
msg$=msg$+left$(MessageText$,TextLengthPtr.length.struct)
If msg$ <> "" Then
Notice "LB ODBC Error"+chr$(13)+msg$
Else
Notice "LB ODBC Error"+chr$(13)+"An unKnown error occured. Check your code."
End if
End Sub
|
|
Oh, why is that more helpful? I tried the first version of it that you posted and it seems to work fine, for me anyways.