VBA-Programm zum Auslesen von Feldbeschreibungen

Subject:

Comments:: In der November-Ausgabe von News/400 stand folgendes Programm zum Auslesen von AS/400 Feldbeschreibungen. : Ich habe jetzt eine Access-DB mit einer ODBC-Verknüpfung zur AS/400 erstellt und das Programm als Modul erstellt. : Mein Programm sieht so aus: : Option Compare Database : Option Explicit : Sub MakePTQueries() : Dim qdfPTQuery As QueryDef : Dim tdfLoop As TableDef : Dim sQueryName As String : With CurrentDb : For Each tdfLoop In .TableDefs : With tdfLoop : 'if it is a linked table, make it a passthrough query : If .Properties("SourceTableName") <> "" Then : sQueryName = "PT - " & .Name : 'Delete existing : On Error Resume Next : 'ignore Errors : CurrentDb.QueryDefs.Delete (sQueryName) : On Error GoTo 0 : Set qdfPTQuery = CurrentDb.CreateQueryDef(sQueryName) : qdfPTQuery.Connect = tdfLoop.Connect : qdfPTQuery.SQL = _ : LongNameSQLSelect(.Properties("SourceTableName"), .Connect) : End If : End With : Next : End With : MsgBox "Query Creation Complete" : End Sub : : Function LongNameSQLSelect(sSourceQualifiedTable As String, sConnect As String) As String : Dim rsD As Recordset : Dim qdfDescription As QueryDef : Dim sSourceLibrary As String : Dim sSourceTable As String : Dim sTempSQL As String : sSourceLibrary = Mid$(sSourceQualifiedTable, 1, InStr(1, sSourceQualifiedTable, ".") - 1) : sSourceTable = Mid$(sSourceQualifiedTable, InStr(1, sSourceQualifiedTable, ".") + 1) : Set qdfDescription = CurrentDb.CreateQueryDef("") : With qdfDescription : .Connect = sConnect : .SQL = "SELECT column_name, column_text, ordinal_position FROM qsys.syscolumns " & _ : "WHERE table_name=´ " & UCase(sSourceTable) & " ´ and " & _ : "TABLE_SCHEMA=´ " & UCase(sSourceLibrary) & " ´ " & _ : "ORDER BY ordinal_position" : : Set rsD = .OpenRecordset() : ___________________________________________________________ : Jedoch hält das Programm beim Ausführen hier an und ich erhalte diese Fehlermeldung: : Laufzeitfehler 3146 : ODBC-CALL failed : ___________________________________________________________ : : If Not rsD.EOF Then : sTempSQL = "Select " : Do While Not rsD.EOF : 'use the description if it´s not null. otherwise use the name : sTempSQL = sTempSQL & rsD("column_name") & " as " & _ : FixDescription(IIf(IsNull(rsD("column_text")), rsD("column_text"), _ : rsD("column_name"))) & ", " : rsD.MoveNext : Loop : ' trim off the extra comma : sTempSQL = Mid$(sTempSQL, 1, Len(sTempSQL) - 2) : ' then build the rest if the statement : sTempSQL = sTempSQL & " from " & sSourceQualifiedTable : Else : MsgBox "No records for table " & sSourceQualifiedTable & " in system catalog." : End : End If : End With : LongNameSQLSelect = sTempSQL : End Function : Function FixDescription(sDesc As String) As String : 'fix description field to be a valid AS/400 SQL description : 'trim description and replace spaces with underscores : Dim nStrLen As Long : Dim nIdx As Long : sDesc = Left$(sDesc, 30) : nIdx = 1 : nStrLen = Len(sDesc) : Do While (nIdx < nStrLen) And nIdx > 0 : nIdx = InStr(nIdx, sDesc, " ") : If nIdx > 0 Then : sDesc = Mid$(sDesc, 1, nIdx - 1) & "_" & Mid$(sDesc, nIdx + 1) : End If : Loop : FixDescription = sDesc : End Function : : Ich hoffe, daß mir jemand helfen kann. : Besten Dank schon im voraus : Gruß ALex