请教大家: VB创建Access文件出错

Question

Private Sub Tools_Print()
Dim psSql As String
psSql = "select * From db_goods "     
Set rst = QueryCn.OpenResultset(psSql, 2)
Succ = CrtRptMdb(rst, "billow", "GoodInst", False)
With Rpt1
    .DataFiles(0) = App.Path & "\billow.mdb"
    .WindowState = crptMaximized
    .ReportFileName = App.Path & "\" & Get_Rpt_File(Me.Caption) & ".rpt"
    .Action = 1
End With
End Sub
'DB_goods 是个视图,里面关联了四个外键表
'这里在Access里创建数据表
Public Function CrtRptMdb(MyResultset As rdoResultset, cfilename As String, cTableName As String, Optional bDropDB As Boolean)
Dim cMySql As String
Dim cNewTable As String
Dim mydb As Variant
Dim Myrecordset As Variant
Dim i As Integer
Dim nFieldNum As Integer
Dim cField As String
'On Error GoTo ErrorHandle
On Error Resume Next
'MkDir DIRMDB
On Error GoTo errorhandle
cfilename = UCase(Trim(cfilename))
'If bDropDB = True And Dir(app.Path  + "\" + cFileName + ".MDB") <> "" Then Kill App.Path + "\" + cFileName + ".MDB"
If bDropDB = True And Dir(App.Path + "\" + cfilename + ".MDB") <> "" Then Kill App.Path + "\" + cfilename + ".MDB"
'If Dir(App.Path + "\" + cFileName + ".MDB") = "" Then
If Dir(App.Path + "\" + cfilename + ".MDB") = "" Then
   Set mydb = DBEngine.Workspaces(0).CreateDatabase(App.Path + "\" + cfilename + ".mdb", dbLangGeneral, dbEncrypt)
Else
   Set mydb = DBEngine.Workspaces(0).OpenDatabase(App.Path + "\" + cfilename + ".mdb")
End If'SetMsg "Creating table report ....."
If Trim(cTableName) = "" Then
   MsgBox "You must offer table name when creating report table !!", vbCritical
   Exit Function
End If
On Error Resume Next
mydb.Execute "drop table " & cTableNameOn Error GoTo errorhandle
cNewTable = "Create Table " & cTableName & " ("
With MyResultset
    For i = 0 To .rdoColumns.Count - 1
    Dim colname As String
        colname = .rdoColumns(i).name
'************************************************************************************
'***   tBinary -2   tBit -7   tChar 1.   tDateTime 11   tDecimal 3   tfloar 6   tImage -4
'***   tInt 4.   tMoney 3.   tNumeric 2.   tReal 7   tSmalldatetime 11   tSmallint 5.
'***   tSmallmoney 3   tSysname 12.   tText -1   tTimestamp -2   tTinyint -6.
'***   tVarbinary -3   tVarchar 12
'************************************************************************************
        Select Case .rdoColumns(i).Type
             Case 1, 12
                  cField = colname & " Char(" & .rdoColumns(i).Size & ")"
             Case -6, 5
                  cField = colname & " Integer"
             Case 4
                  cField = colname & " Long"
             Case 2, 6, 7
                  If .rdoColumns(i).Size < 6 Then
                     cField = colname & " Single"
                  Else
                     cField = colname & " Double"
                  End If
             Case 3
                  cField = colname & " Currency"
             Case -7
                  cField = colname & " Boolean"
             Case 11, -2
                  cField = colname & " Date"
             Case -4, -1, -3
                  cField = colname & " Memo"
             Case Else
                  cField = colname & " Char(" & .rdoColumns(i).Size & ")"
      End Select
      cNewTable = cNewTable & cField & ","
   Next
End With
cNewTable = Mid(cNewTable, 1, Len(cNewTable) - 1) & ")"
'Dim tt1 As Date
'tt1 = Now
mydb.Execute cNewTable    
'每次执行到这里的时候就出错了
'SetMsg "Create local database successfully !!"
Set Myrecordset = mydb.OpenRecordset("select * from " & cTableName, dbOpenDynaset)'SetMsg "Copying report data from SqlServer to local database....."
'Workspaces(0).BeginTrans
nFieldNum = MyResultset.rdoColumns.Count - 1
If Not MyResultset.EOF Then
  MyResultset.MoveFirst
End If
Do While Not MyResultset.EOF
   'If MyResultset.AbsolutePosition Mod 33 = 0 Then SetMsg "Receiving records  " & MyResultset.AbsolutePosition
   Myrecordset.AddNew
   For i = 0 To nFieldNum
       Myrecordset.Fields(i).Value = MyResultset.rdoColumns(i).Value
   Next
   Myrecordset.Update
   MyResultset.MoveNext
Loop
CrtRptMdb = True
Exit Function
errorhandle:
  Set mydb = Nothing
  MsgBox Err.Description, vbCritical
  CrtRptMdb = False
End Function
如果不关联外键表能够正常执行,请大家帮忙检查一下!!

Answer 1

靠，粘这么多，让我们看戏阿，我给你段代码也是建库的，自己看去吧    Dim com As ADODB.Command
    Dim wrkDefault As Workspace
    Dim dbsNew As Database
    Dim tdfNew As TableDef
    Dim NewDB As Database
    If Not Dir(App.Path & "\data\" & Hstrid & ".glory") <> "" Then
        Set wrkDefault = DBEngine.Workspaces(0)
        Set dbsNew = wrkDefault.CreateDatabase(App.Path & "\data\" & Hstrid & ".glory", dbLangGeneral, dbEncrypt)
        Set wrkDefault = Nothing
        Set dbsNew = Nothing

Answer 2

Private  Sub  Command1_Click()  
       Dim  tdExample  As  TableDef  
       Dim  fldForeName  As  Field  
       Dim  fldSurname  As  Field  
       Dim  fldDOB  As  Field  
       Dim  fldFurtherDetails  As  Field  
       Dim  dbDatabase  As  Database  
       Dim  sNewDBPathAndName  As  String  
         
       sNewDBPathAndName  =  "d:\NewDB"  &  Right$(Time,  2)  &  ".mdb"  
       Set  dbDatabase  =  CreateDatabase(sNewDBPathAndName,  dbLangGeneral,  dbEncrypt)  
       Set  tdExample  =  dbDatabase.CreateTableDef("DongGe")  'Example")  
 
       Set  fldForeName  =  tdExample.CreateField("Fore_Name",  dbText,  20)  
       Set  fldSurname  =  tdExample.CreateField("Surname",  dbDouble,  20)  
       Set  fldDOB  =  tdExample.CreateField("DOB",  dbDate)  
       Set  fldFurtherDetails  =  tdExample.CreateField("Further_Details",  dbMemo)  
         
       tdExample.Fields.Append  fldForeName  
       tdExample.Fields.Append  fldSurname  
       tdExample.Fields.Append  fldDOB  
       tdExample.Fields.Append  fldFurtherDetails  
         
       dbDatabase.TableDefs.Append  tdExample  
       MsgBox  "New  .MDB  Created  -  '"  &  sNewDBPathAndName  &  "'",  vbInformation  
End  Sub

Answer 3

绝对标准                     我急需分  把分给我吧
用ADO列出某个表的所有字段、索引  
 
  查询类型                标准
   =============================   adSchemaTables             TABLE_CATALOG
                              TABLE_SCHEMA
                              TABLE_NAME
                              TABLE_TYPE
 
使用 adSchemaTables 列出数据库中所有的表
在 Microsoft Access 97 and Access 2000 中以下例子展示了如何列出northwind数据库中所有的表和查询
 Set rs = cn.OpenSchema(adSchemaTables)
   While Not rs.EOF
      Debug.Print rs!TABLE_NAME
      rs.MoveNext
   Wend 
只列出表用以下的代码：            
Set rs = cn.OpenSchema(adSchemaTables, _
         Array(Empty, Empty, Empty, "Table") 在 Microsoft SQL Server 6.5 and 7.0 中以下代码列出Publs中所有的表和视图
Set rs = cn.OpenSchema(adSchemaTables) 
只列出所有表用：    
 Set rs = cn.OpenSchema(adSchemaTables, _
         Array("Pubs", Empty, Empty, "Table")                 
 查询类型                标准字
   ===============================   adSchemaColumns   TABLE_CATALOG
                     TABLE_SCHEMA
                     TABLE_NAME
                     COLUMN_NAME
                 
用 adSchemaColumns 列出表中所有字段
在 Microsoft Access 97 and Access 2000 中列出 northwind.mdb 数据库 employees 表的所有字段代码如下：
Set rs = cn.OpenSchema(adSchemaColumns,Array(Empty, Empty, "Employees")While Not rs.EOF
   Debug.Print rs!COLUMN_NAME
   rs.MoveNext
Wend
 
注意：需要OLE DB Provider for ODBC 和 Jet ODBC Driver 和 Jet OLE DB Providers支持在 Microsoft SQL Server 6.5 and 7.0 中列出 Pubs database 中  Authors 表的所有字段用以下代码：
Set rs = cn.OpenSchema(adSchemaColumns, Array("pubs", "dbo", "Authors") 
            
   查询类型              标准字
   ================================   adSchemaIndexes    TABLE_CATALOG
                      TABLE_SCHEMA
                      INDEX_NAME
                      TYPE
                      TABLE_NAME
 
在下面例子中你必须提供一个索引名让 adSchemaIndexes querytype 使用
在 Microsoft Access 97 and Access 2000 中列出 northwind.mdb 数据库的 employees 表的所有索引用以下代码：
 Set rs = cn.OpenSchema(adSchemaIndexes, _
         Array(Empty, Empty, Empty, Empty, "Employees")While Not rs.EOF
   Debug.Print rs!INDEX_NAME
   rs.MoveNext
Wend
 在 Microsoft SQL Server 6.5 and 7.0 中列出 Pusb 数据库 Authors 表的所有索引用以下代码：
 Set rs = cn.OpenSchema(adSchemaIndexes, _
         Array("Pubs", "dbo", Empty, Empty, "Authors") 下面是一段完整的代码展示如何在 Sql Server + VB 中使用：
   'Open the proper connection.
   Dim cn As New ADODB.Connection
   Dim rs As New ADODB.Recordset   Private Sub Command1_Click()
   'Getting the information about the columns in a particular table.
      Set rs = cn.OpenSchema(adSchemaColumns, Array("pubs", "dbo", _
             "authors"))
      While Not rs.EOF
          Debug.Print rs!COLUMN_NAME
          rs.MoveNext
      Wend   End Sub   Private Sub Command2_Click()
   'Getting the information about the primary key for a table.
      Set rs = cn.OpenSchema(adSchemaPrimaryKeys, Array("pubs", "dbo", _
             "authors"))
      MsgBox rs!COLUMN_NAME
   End Sub   Private Sub Command3_Click()
   'Getting the information about all the tables.
      Dim criteria(3) As Variant
      criteria(0) = "pubs"
      criteria(1) = Empty
      criteria(2) = Empty
      criteria(3) = "table"
      Set rs = cn.OpenSchema(adSchemaTables, criteria)
      While Not rs.EOF
         Debug.Print rs!TABLE_NAME         rs.MoveNext
      Wend   End Sub   Private Sub Form_Load()
      cn.Open "dsn=pubs;uid=sa;pwd=;"
      'To test with the Native Provider for SQL Server, comment the
      ' line above then uncomment the following line. Modify to use
      ' your server.
      'cn.Open "Provider=SQLOLEDB;Data Source=<servername>;" & _
      '        "User ID=sa;password=;"   End Sub
  
 

Answer 4

 Access 系统表 MsysObjects 包含了数据库对象列表, 尽管未在文档中记载, 你仍可通过查询它来获取你想要的.注: 请不要有意或无意地修改任何ACCESS系统表,否则会出现不可意料的情况.使用下列 SQL 语句来获取你想要的查询:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left([Name],1)<>"~") AND (MSysObjects.Type)=5 ORDER BY MSysObjects.Name; 
窗体:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left([Name],1)<>"~") AND (MSysObjects.Type)=-32768 ORDER BY MSysObjects.Name; 
表:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left([Name],1)<>"~") AND (Left$([Name],4) <> "Msys") AND (MSysObjects.Type)=1 ORDER BY MSysObjects.Name; 
报表:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left([Name],1)<>"~") AND (MSysObjects.Type)= -32764 ORDER BY MSysObjects.Name; 
模块:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left([Name],1)<>"~") AND (MSysObjects.Type)= -32761 ORDER BY MSysObjects.Name; 
宏:
SELECT MSysObjects.Name FROM MsysObjects WHERE (Left([Name],1)<>"~") AND (MSysObjects.Type)= -32766 ORDER BY MSysObjects.Name;
 

Answer 5

这些资料出自 [yoki]   很有价值