http://www.chenoe.com/blog/article.asp?id=1910 使用ADOX动态创建数据库,表,字段.暂时还没有写完整,但此部份己能正常使用。 TCreateDataBase.cls''''欢迎你下载使用本代码,本份代码由程序太平洋提供下载学习之用 ''''声明: ''''1.本站所有代码的版权归原作者所有,如果你使用了在本站下载的源代码 '''' 引起的一切纠纷(后果)与本站无关,请您尊重原作者的劳动成果! ''''2.若本站在代码上有侵权之处请您与站长联系,站长会及时更正。 ''''论坛:http://www.5ivb.net ''''Email:[email protected] ''''CopyRight 2001-2005 By dapha.net ''''整理时间:2004-7-31 22:10:30Option Explicit Public Enum DataBaseVer ACCESS97 = 1 ACCESS2000 = 2 End Enum Private obj_Cat As ADOX.Catalog Private obj_table As ADOX.Table Dim obj_col As Column Private m_DBName As String ''''数据库名称 Private m_DBVer As DataBaseVer ''''数据库版本 Private strConnection As String ''''数据库连接驱动 Public Property Let DataBaseName(ByVal value As String) m_DBName = value End Property Public Property Let SetDataBaseVer(ByVal value As DataBaseVer) m_DBVer = value End Property Public Function CreateDataBase(Optional DataBaseName As String = "", Optional p_DBVer As DataBaseVer, Optional OverWrite As Boolean = False) As Boolean ''''DataBaseName 数据库名称 ''''数据库版本 1.ACCESS97 2.ACCESS2000 ''''OverWrite 是否重写原有的数据库 False 不需要 True 需要 On Error GoTo errorhand If p_DBVer > 0 Then m_DBVer = p_DBVer If Len(Trim(DataBaseName)) > 0 Then m_DBName = DataBaseName Select Case m_DBVer Case 1 strConnection = GetDBConnection Case 2 strConnection = GetDBConnection(True) Case Else Err.Raise 30001, "TCreateDataBase", "数据库选择参数未选" End Select If Len(Trim(m_DBName)) = 0 Then Err.Raise 30002, "TCreateDataBase", "文件名错误---空的文件名" End If obj_Cat.Create strConnection CreateDataBase = True Exit Function errorhand: If OverWrite Then Kill m_DBName Resume ''''返回错误发生处 Else Err.Raise 30006, "TCreateDataBase", "数据库己存在" End If CreateDataBase = False End Function Public Function CrateTable(ByVal TableName As String, Optional OverWrite As Boolean = False) On Error GoTo errhand: If obj_Cat Is Nothing Then Err.Raise 30003, "TCreateDataBase----CreateTable", "对象不存在" Exit Function End If Set obj_table = New Table obj_table.Name = TableName obj_Cat.Tables.Append obj_tableExit Function errhand:End Function Private Function GetDBConnection(Optional ByVal value As Boolean = False) As String If value Then GetDBConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & m_DBName & ";" Else GetDBConnection = "Provider=Microsoft.Jet.OLEDB.3.51;" & _ "Data Source=" & m_DBName & ";" End If End Function Private Sub Class_Initialize() Set obj_Cat = New ADOX.CatalogEnd Sub Public Function CreateColumn(ByVal ColName As String, ByVal pType As DataTypeEnum, _ Optional ByVal Size As Integer = 255, Optional ByVal AutoInc As Integer = 0, _ Optional ByVal Nullable As Integer = 0, _ Optional ByVal Defaultvalue As Variant = vbEmpty) As Boolean ''''ColName 列名 ''''pType 数据类型 ''''Size 类型大小 ''''AutoInc 如果是int型,是否设置为自动增长 ''''Nullable是否允许为空 0,默认(必填项) 1 允许为空 ''''Defaultvalue 默认值 由于时间原因,只能这样应付着了 需要和类型配合否则有可能出错 ''''如:.CreateColumn "Age", adInteger, , , , 4 Integer型,默认值 4 '''' .CreateColumn "UserName", adVarWChar, 20, , , "wangfeng" 文本型,默认值 wangfeng On Error GoTo CreateColumn_Error Set obj_col = New ADOX.Column With obj_col .Name = ColName .Type = pType If .Type >= adVarChar Then .DefinedSize = Size Set .ParentCatalog = obj_Cat If .Type = adInteger Then .Properties("Autoincrement") = (AutoInc = 1) .Properties("Nullable") = (Nullable = 1) If Defaultvalue <> vbEmpty Then .Properties("Default").value = Defaultvalue End If End With obj_table.Columns.Append obj_col CreateColumn = True Exit Function CreateColumn_Error: CreateColumn = False '''' Err.Raise 30004, "TCreateDataBase----CreateColumn", "未知错误" End Function Private Sub Class_Terminate() Set obj_col = Nothing Set obj_table = Nothing Set obj_Cat = Nothing End Sub 使用此类,需要引ADOX对象示例: '欢迎你下载使用本代码,本份代码由程序太平洋提供下载学习之用 '声明: '1.本站所有代码的版权归原作者所有,如果你使用了在本站下载的源代码 ' 引起的一切纠纷(后果)与本站无关,请您尊重原作者的劳动成果! '2.若本站在代码上有侵权之处请您与站长联系,站长会及时更正。 '论坛:http://www.5ivb.net 'Email:[email protected] 'CopyRight 2001-2005 By dapha.net '整理时间:2004-7-31 22:10:30Option Explicit Private Sub Command1_Click() On Error GoTo errhand Dim i As Integer, j As Integer Dim obj_Create As TCreateDataBase Set obj_Create = New TCreateDataBase With obj_Create .DataBaseName = "c:\wf.mdb" .SetDataBaseVer = ACCESS2000 .CreateDataBase , , True '参数三 是否覆盖 .CrateTable "UserInfo" .CreateColumn "ID", adInteger, , 1 '自动增长 .CreateColumn "UserName", adVarWChar, 20, , , "wangfeng" '长度为20 .CreateColumn "Age", adInteger, , , , 24 .CreateColumn "Address", adVarWChar, , , 1 '必填 否 For i = 1 To 10 .CrateTable "Test" & CStr(i) For j = 1 To 10 .CreateColumn "Test" & CStr(j), adInteger Next Next End With Set obj_Create = Nothing MsgBox "数据库建立成功!", vbInformation, "提示" Exit Sub errhand: MsgBox Err.Description End Sub
使用ADOX动态创建数据库,表,字段.暂时还没有写完整,但此部份己能正常使用。
TCreateDataBase.cls''''欢迎你下载使用本代码,本份代码由程序太平洋提供下载学习之用
''''声明:
''''1.本站所有代码的版权归原作者所有,如果你使用了在本站下载的源代码
'''' 引起的一切纠纷(后果)与本站无关,请您尊重原作者的劳动成果!
''''2.若本站在代码上有侵权之处请您与站长联系,站长会及时更正。
''''论坛:http://www.5ivb.net
''''Email:[email protected]
''''CopyRight 2001-2005 By dapha.net
''''整理时间:2004-7-31 22:10:30Option Explicit
Public Enum DataBaseVer
ACCESS97 = 1
ACCESS2000 = 2
End Enum
Private obj_Cat As ADOX.Catalog
Private obj_table As ADOX.Table
Dim obj_col As Column
Private m_DBName As String ''''数据库名称
Private m_DBVer As DataBaseVer ''''数据库版本
Private strConnection As String ''''数据库连接驱动
Public Property Let DataBaseName(ByVal value As String)
m_DBName = value
End Property
Public Property Let SetDataBaseVer(ByVal value As DataBaseVer)
m_DBVer = value
End Property
Public Function CreateDataBase(Optional DataBaseName As String = "", Optional p_DBVer As DataBaseVer, Optional OverWrite As Boolean = False) As Boolean
''''DataBaseName 数据库名称
''''数据库版本 1.ACCESS97 2.ACCESS2000
''''OverWrite 是否重写原有的数据库 False 不需要 True 需要
On Error GoTo errorhand
If p_DBVer > 0 Then m_DBVer = p_DBVer
If Len(Trim(DataBaseName)) > 0 Then m_DBName = DataBaseName
Select Case m_DBVer
Case 1
strConnection = GetDBConnection
Case 2
strConnection = GetDBConnection(True)
Case Else
Err.Raise 30001, "TCreateDataBase", "数据库选择参数未选"
End Select
If Len(Trim(m_DBName)) = 0 Then
Err.Raise 30002, "TCreateDataBase", "文件名错误---空的文件名"
End If
obj_Cat.Create strConnection
CreateDataBase = True
Exit Function
errorhand:
If OverWrite Then
Kill m_DBName
Resume ''''返回错误发生处
Else
Err.Raise 30006, "TCreateDataBase", "数据库己存在"
End If
CreateDataBase = False
End Function
Public Function CrateTable(ByVal TableName As String, Optional OverWrite As Boolean = False)
On Error GoTo errhand:
If obj_Cat Is Nothing Then
Err.Raise 30003, "TCreateDataBase----CreateTable", "对象不存在"
Exit Function
End If
Set obj_table = New Table
obj_table.Name = TableName
obj_Cat.Tables.Append obj_tableExit Function
errhand:End Function
Private Function GetDBConnection(Optional ByVal value As Boolean = False) As String
If value Then
GetDBConnection = "Provider=Microsoft.Jet.OLEDB.4.0;" & _
"Data Source=" & m_DBName & ";"
Else
GetDBConnection = "Provider=Microsoft.Jet.OLEDB.3.51;" & _
"Data Source=" & m_DBName & ";"
End If
End Function
Private Sub Class_Initialize()
Set obj_Cat = New ADOX.CatalogEnd Sub
Public Function CreateColumn(ByVal ColName As String, ByVal pType As DataTypeEnum, _
Optional ByVal Size As Integer = 255, Optional ByVal AutoInc As Integer = 0, _
Optional ByVal Nullable As Integer = 0, _
Optional ByVal Defaultvalue As Variant = vbEmpty) As Boolean
''''ColName 列名
''''pType 数据类型
''''Size 类型大小
''''AutoInc 如果是int型,是否设置为自动增长
''''Nullable是否允许为空 0,默认(必填项) 1 允许为空
''''Defaultvalue 默认值 由于时间原因,只能这样应付着了 需要和类型配合否则有可能出错
''''如:.CreateColumn "Age", adInteger, , , , 4 Integer型,默认值 4
'''' .CreateColumn "UserName", adVarWChar, 20, , , "wangfeng" 文本型,默认值 wangfeng
On Error GoTo CreateColumn_Error
Set obj_col = New ADOX.Column
With obj_col
.Name = ColName
.Type = pType
If .Type >= adVarChar Then .DefinedSize = Size
Set .ParentCatalog = obj_Cat
If .Type = adInteger Then .Properties("Autoincrement") = (AutoInc = 1)
.Properties("Nullable") = (Nullable = 1)
If Defaultvalue <> vbEmpty Then
.Properties("Default").value = Defaultvalue
End If
End With
obj_table.Columns.Append obj_col
CreateColumn = True
Exit Function
CreateColumn_Error:
CreateColumn = False
'''' Err.Raise 30004, "TCreateDataBase----CreateColumn", "未知错误"
End Function
Private Sub Class_Terminate()
Set obj_col = Nothing
Set obj_table = Nothing
Set obj_Cat = Nothing
End Sub
使用此类,需要引ADOX对象示例:
'欢迎你下载使用本代码,本份代码由程序太平洋提供下载学习之用
'声明:
'1.本站所有代码的版权归原作者所有,如果你使用了在本站下载的源代码
' 引起的一切纠纷(后果)与本站无关,请您尊重原作者的劳动成果!
'2.若本站在代码上有侵权之处请您与站长联系,站长会及时更正。
'论坛:http://www.5ivb.net
'Email:[email protected]
'CopyRight 2001-2005 By dapha.net
'整理时间:2004-7-31 22:10:30Option Explicit
Private Sub Command1_Click()
On Error GoTo errhand
Dim i As Integer, j As Integer
Dim obj_Create As TCreateDataBase
Set obj_Create = New TCreateDataBase
With obj_Create
.DataBaseName = "c:\wf.mdb"
.SetDataBaseVer = ACCESS2000
.CreateDataBase , , True '参数三 是否覆盖
.CrateTable "UserInfo"
.CreateColumn "ID", adInteger, , 1 '自动增长
.CreateColumn "UserName", adVarWChar, 20, , , "wangfeng" '长度为20
.CreateColumn "Age", adInteger, , , , 24
.CreateColumn "Address", adVarWChar, , , 1 '必填 否
For i = 1 To 10
.CrateTable "Test" & CStr(i)
For j = 1 To 10
.CreateColumn "Test" & CStr(j), adInteger
Next
Next
End With
Set obj_Create = Nothing
MsgBox "数据库建立成功!", vbInformation, "提示"
Exit Sub
errhand:
MsgBox Err.Description
End Sub