! ------------------------------------------------------------------------------- ! (C) Jörg Kuthe, QT software, München, 1999 and Berlin 2005. All rights reserved ! ------------------------------------------------------------------------------- ! ! LF90 compile & link: ! -------------------- ! lf90 T_ODBCAccessRd.f90 qtODBCLF90.lib -mod c:\lf90\mod&obj -winconsole -ml msvc ! Notice: The directory "c:\lf90\mod&obj" is the path spec. where modules and objects can be found. ! qtODBCLF90.lib ist the import library which contains the ODBC functions being called. ! ! LF95 compile & link: ! -------------------- ! lf95 T_ODBCAccessRd.f90 -lib qtODBCLF95.lib ODBC32.lib -mod d:\LF95.mod&obj -winconsole -ml msvc ! Notice: The directory "d:\LF95.mod&obj" is the path spec. where modules and objects can be found. ! qtODBCLF95.lib ist the library which contains the Interaces to ODBC functions being called. ! ! FTN95 compile & link: ! --------------------- ! ftn95 T_ODBCAccessRd.f90 /mod_path M: ! Notice: The directory "M:" is the path spec. where modules can be found. ! slink commands: ! lo t_odbcaccessrd ! lo c:\windows\system\odbc32.dll ! file ! Notice: ODBC32.dll can be found in the windows system directory, for example "c:\windows\system\odbc32.dll" ! ! DVF & IVF compile & link: ! ------------------------- ! For compilation it is necessary that the project settings contain ! a module path (in case the modules are not found). Select ! Project | Settings, register card 'Fortran', category ! 'Miscellaneous' and enter the module path. ! Since the ODBC library has to be linked too, select ! Project | Settings, register card 'Link', category ! 'General' and add ODBC32.lib in the field 'Object library modules'. ! Take care that ODBC32.lib can be found (it must be on the LIB path of DVF). ! ! Notice: ODBC32.dll can be found in the windows system directory, for example "c:\windows\system\odbc32.dll" MODULE EDSR USE qt_ODBC ! MODULE supplied with ForDBC INTEGER (SQLRETURN) :: rtc INTEGER (SQLHENV) :: env = SQL_NULL_HENV INTEGER (SQLHDBC) :: dbc = SQL_NULL_HDBC INTEGER (SQLHSTMT) :: stmt = SQL_NULL_HSTMT END MODULE EDSR PROGRAM T_ODBCAccessRd ! reads columns from datasource "ODBCTestAccess" USE EDSR USE qt_ODBC_Compiler ! MODULE supplied with ForDBC; FTN95: in qt_ODBC_FTN.f90; LF90: in qt_ODBC_LF90.f90: MSF Powerst.4.0: in qt_ODBC_MsF.f90 IMPLICIT NONE INTEGER*2 Id INTEGER*4 I4 DOUBLE PRECISION DP CHARACTER (LEN=30) :: Str = ' ' ! old INTEGER (KIND=SDWORD) :: LENStr = 30 ! old INTEGER (KIND=SDWORD) :: cbStr, cbFixed INTEGER (SQLINTEGER) :: LENStr = 30 INTEGER (SQLINTEGER) :: cbStr, cbFixedId, cbFixedI4, cbFixedDP INTEGER, PARAMETER :: I2Missing = -9999 INTEGER, PARAMETER :: I4Missing = -99999999 DOUBLE PRECISION, PARAMETER :: DPMissing = -0.999999999999D99 CHARACTER (LEN=*), PARAMETER :: StrMissing = 'missing value' INTEGER (SQLUSMALLINT) :: icol ! ------------------------------------- ! establish environment, connection ... rtc = SQLAllocEnv( env ) CALL CheckSQLReturnCode ( 1, *999) PRINT*,'Environment Handle =', env rtc = SQLAllocConnect ( env, dbc ) CALL CheckSQLReturnCode ( 2, *998) PRINT*,'Connection Handle =', dbc PRINT*,'SQLConnect to ODBCTestAccess (this DSN has to be set up before using this program).' ! The ForDBC manual shows how to set up a data source name (DSN). rtc = SQLConnect( dbc, "ODBCTestAccess"//CHAR(0), SQL_NTS, & CHAR(0), SQL_NTS, CHAR(0), SQL_NTS ) ! note: strings are zero terminated ("//CHAR(0) appended") CALL CheckSQLReturnCode (2, *997) PRINT*,'Connect successful' ! -------------------- ! set up SQL statement rtc = SQLAllocStmt (dbc, stmt) CALL CheckSQLReturnCode (3, *996) PRINT*,'Memory for statement allocated' rtc = SQLExecDirect ( stmt, & "SELECT id, i4, dp, str FROM Tabelle1"//CHAR(0), SQL_NTSL ) CALL CheckSQLReturnCode (3, *995) PRINT*,'SELECT Statement successfully executed' ! ------------------- ! bind result columns icol = 1 rtc = SQLBindColI2 (stmt, icol, SQL_C_SSHORT, Id, 0, cbFixedId ) CALL CheckSQLReturnCode (3, *995) icol = 2 rtc = SQLBindColI4 (stmt, icol, SQL_C_SLONG, I4, 0, cbFixedI4 ) CALL CheckSQLReturnCode (3, *995) icol = 3 rtc = SQLBindColDP (stmt, icol, SQL_C_DOUBLE, DP, 0, cbFixedDP ) CALL CheckSQLReturnCode (3, *995) icol = 4 rtc = SQLBindColChar (stmt, icol, SQL_C_CHAR, Str, LENStr, cbStr ) CALL CheckSQLReturnCode (3, *995) PRINT*,'Bind successfull' ! ---------- ! fetch data PRINT*,'SQL Fetch:' PRINT*,' Id I4 DP Str cbStr' ! 123456789 123456789 123456789 123456789 123456789 123456789 123456789 DO WHILE (.TRUE.) rtc = SQLFetch(stmt) IF ( rtc .EQ. SQL_NO_DATA_FOUND ) EXIT CALL CheckSQLReturnCode (3, *994) WRITE (*,6000) Id, I4, DP, Str, cbStr IF ( cbFixedId == SQL_NULL_DATA ) THEN Id = I2Missing PRINT*, 'Id is missing value' PAUSE END IF IF ( cbFixedI4 == SQL_NULL_DATA ) THEN I4 = I4Missing PRINT*, 'I4 is missing value' PAUSE END IF IF ( cbFixedDP == SQL_NULL_DATA ) THEN DP = DPMissing PRINT*, 'DP is missing value' PAUSE END IF IF ( cbStr == SQL_NULL_DATA ) THEN Str = StrMissing PRINT*, 'Str is missing value' PAUSE END IF END DO 6000 FORMAT( 1X,I3, 1X,I8, 1X,F21.6, 1X,A, 1X,I5 ) ! --------------------------------------------- ! done - free statement handle, disconnect etc. 994 rtc = SQLFreeStmt (stmt, SQL_UNBIND) CALL CheckSQLReturnCode (3, *999) PRINT*,'Statement unbound' 995 rtc = SQLFreeStmt (stmt, SQL_DROP) CALL CheckSQLReturnCode (3, *999) PRINT*,'Statement dropped' 996 rtc = SQLDisconnect (dbc) CALL CheckSQLReturnCode (2, *999) PRINT*,'Disconnected' 997 rtc = SQLFreeConnect (dbc) CALL CheckSQLReturnCode (2, *999) PRINT*,'Connection freed' 998 rtc = SQLFreeEnv(env) CALL CheckSQLReturnCode (1, *999) PRINT*,'Environment freed' PRINT*,'Program successfully terminated.' PAUSE STOP 999 PRINT*,'Program terminated preliminary because of an error.' PAUSE STOP END PROGRAM SUBROUTINE CheckSQLReturnCode ( hKey, * ) ! check error associated with ! hKey = 1: env ! = 2: dbc ! = 3: stmt USE EDSR USE qt_ODBC_Compiler ! FTN95: in qt_ODBC_FTN.f90; LF90: in qt_ODBC_LF90.f90 IMPLICIT NONE INTEGER (KIND=SDWORD) :: nativeError CHARACTER (LEN=SQL_MAX_MESSAGE_LENGTH) :: szSQLState, szErrorMsg INTEGER (KIND=SWORD) :: ErrorMsgMax = SQL_MAX_MESSAGE_LENGTH - 1 , ErrorMsgAv, hKey INTEGER (KIND=RETCODE) :: locrtc INTEGER (SQLHENV) :: locEnv, locDbc, locStmt INTEGER iLen IF (rtc .EQ. SQL_SUCCESS) THEN RETURN ELSE IF (rtc .EQ. SQL_SUCCESS_WITH_INFO .OR. rtc .EQ. SQL_ERROR) THEN SELECT CASE (hKey) CASE (1) locEnv = env locDbc = SQL_NULL_HSTMT locStmt = SQL_NULL_HSTMT CASE (2) locEnv = SQL_NULL_HSTMT locDbc = dbc locStmt = SQL_NULL_HSTMT CASE (3) locEnv = SQL_NULL_HSTMT locDbc = SQL_NULL_HSTMT locStmt = stmt CASE DEFAULT PRINT*, 'CheckSQLReturnCode: invalid hKey used.' END SELECT locrtc = SQLError (locEnv, locDbc, locStmt, szSQLState, nativeError, & szErrorMsg, ErrorMsgMax, ErrorMsgAv ) PRINT* PRINT*, 'SQLError (=', locrtc, '):' iLen = MIN(INDEX(szSQLState, CHAR(0)), LEN_TRIM(szSQLState)) IF ( iLen > 0 ) PRINT*, ' SQLState: ', szSQLState(1:iLen) PRINT*, ' SQLErrorMessage: ',szErrorMsg(1:ErrorMsgAv) PRINT*, ' Native error (specific to the data source):',nativeError IF (rtc .EQ. SQL_SUCCESS_WITH_INFO) RETURN PRINT*,'Error code returned:',rtc ELSE PRINT*,'Unknown error code returned:',rtc END IF RETURN 1 END SUBROUTINE CheckSQLReturnCode