mod_access.bas

导出Access、Sql Server数据库表到Html vb源吗

         GetTypeName = "adUserDefined"
         
      '二进制值（仅 Parameter 对象）。
      Case adVarBinary
         GetTypeName = "adVarBinary"
         
      '字符串值（仅 Parameter 对象）。
      Case adVarChar
         GetTypeName = "adVarChar"
         
      '自动变体型 (DBTYPE_VARIANT)。
      Case adVariant
         GetTypeName = "adVariant"
         
      '与其他类型一起加入逻辑 OR 中，指示数据是 DBVECTOR 结构（由 OLE DB 定义）。
      '该结构含有元素的计数和其他类型 (DBTYPE_VECTOR) 数据的指针。
      Case adVector
         GetTypeName = "adVector"
         
      '以空结尾的 Unicode 字符串（仅 Parameter 对象）。
      Case adVarWChar
         'GetTypeName = "adVarWChar"
         GetTypeName = "文本"
      '以空结尾的 Unicode 字符串 (DBTYPE_WSTR)。
      Case adWChar
         GetTypeName = "adWChar"
         
   End Select
   
   GetTypeName = GetTypeName & "(" & intType & ")"
End Function

'取数据库里的其他信息
Function GetElseInfo(ByVal lngVal As Long) As String
   Select Case lngVal
      '指示字段被延迟，即不从拥有整个记录的数据源检索字段值，仅在显式访问这些字段时才进行检索。
      Case adFldMayDefer
         GetElseInfo = "adFldMayDefer"
         
      '指示可以写入该字段。
      Case adFldUpdatable
         GetElseInfo = "adFldUpdatable"
      
      '指示提供者无法确定是否可以写入该字段。
      Case adFldUnknownUpdatable
         GetElseInfo = "adFldUnknownUpdatable"
      
      '指示该字段包含定长数据。
      Case adFldFixed
         GetElseInfo = "adFldFixed"
      
      '指示该字段接受 Null 值。
      Case adFldIsNullable
         GetElseInfo = "adFldIsNullable"
      
      '指示可以从该字段读取 Null 值。
      Case adFldMayBeNull
         GetElseInfo = "adFldMayBeNull"
      
      '指示该字段为长二进制字段。并指示可以使用 AppendChunk 和 GetChunk 方法。
      Case adFldLong
         GetElseInfo = "adFldLong"
      
      '指示字段包含持久的行标识符，
      '该标识符无法被写入并且除了对行进行标识（如记录号、唯一标识符等）外不存在有意义的值。
      Case adFldRowID
         GetElseInfo = "adFldRowID"
      
      '指示该字段包含用来跟踪更新的某种时间或日期标记。
      Case adFldRowVersion
         GetElseInfo = "adFldRowVersion"
      
      '指示提供者缓存了字段值，并已完成随后对缓存的读取。
      Case adFldCacheDeferred
         GetElseInfo = "adFldCacheDeferred"
         
      '默认值?指示该参数接受带符号的值?
      Case adParamSigned
         GetElseInfo = "adParamSigned"
         
      '指示该参数接受 Null 值。
      Case adParamNullable
         GetElseInfo = "adParamNullable"
         
      '指示该参数接受长二进制数据?
      Case adParamLong
         GetElseInfo = "adParamLong"
         
      '指示提供者不支持该属性
      Case adPropNotSupported
         GetElseInfo = "adPropNotSupported"
      
      '指示数据源初始化之前用户必须指定该属性的值?
      Case adPropRequired
         GetElseInfo = "adPropRequired"
      
      '指示数据源初始化之前用户不必为该属性指定值?
      Case adPropOptional
         GetElseInfo = "adPropOptional"
      
      '指示用户可以读取该属性?
      Case adPropRead
         GetElseInfo = "adPropRead"
      
      '指示用户可以设置该属性?
      Case adPropWrite
         GetElseInfo = "adPropWrite"
   
      '执行保留的提交，即通过自动调用 CommitTrans 启动新事务。并非所有提供者都支持该常量。
      Case adXactCommitRetaining
         GetElseInfo = "adXactCommitRetaining"
      
      '执行保留的中止，即通过自动调用 RollbackTrans 启动新事务。并非所有提供者都支持该常量。
      Case adXactAbortRetaining
         GetElseInfo = "adXactAbortRetaining"

      Case adFldMayDefer Or adFldUnknownUpdatable Or adFldFixed Or adFldMayBeNull
         GetElseInfo = "adFldMayDefer + adFldUnknownUpdatable + adFldFixed + adFldMayBeNull"
         
   End Select
   
   GetElseInfo = GetElseInfo & "," & lngVal
End Function

'取一个字段是否为必填字段及其他一些属性
Public Function GetFieldIndex(ByVal strTabName As String, _
                              ByVal strFieldName As String, _
                              ByVal strConn As String, _
                              strDefault As String, _
                              strDescription As String) As String
   Dim MyDB                         As New ADOX.Catalog
   Dim MyTable                      As ADOX.Table
   Dim MyField                      As ADOX.Column
   Dim pro
   
   
   On Local Error GoTo LocalErr
   
   MyDB.ActiveConnection = strConn
   
   '这里循环次数有点多，但我想不到什么好方法。
   For Each MyTable In MyDB.Tables
      If MyTable.Name = strTabName Then
         For Each MyField In MyTable.Columns
            If MyField.Name = strFieldName Then
               For Each pro In MyField.Properties
                  Select Case pro.Name
                     Case "Nullable"
                        GetFieldIndex = pro.Value
                        If GetFieldIndex = "True" Then
                           GetFieldIndex = "False"
                        Else
                           GetFieldIndex = "True"
                        End If
                     
                     Case "Default"
                        strDefault = pro.Value
                        
                     Case "Description"
                        strDescription = pro.Value
                        
                  End Select

               Next
            End If
         Next
      End If
   Next
   
ExitFor:
   Set MyDB = Nothing
   Exit Function

LocalErr:
   GetFieldIndex = "False"
End Function


'取得ACCESS数据库里的表的说明
'先引用 Microsoft DAO 3.6 Object Library
'参数说明:
'         strFileName         完整文件名
'         strTable            要取某个字段所在的表名
'返    回:
'         成功                表的说明
'         失败                空字符串("")
'例    子:
'         strDes=GetTabDescription("C:\data.mdb", "MyTab")
Public Function GetTabDescription(ByVal strFileName As String, _
                                  ByVal strTable As String) As String
   Dim DAO_WORK                     As DAO.Workspace
   Dim DB                           As DAO.Database
   Dim DAO_Rset                     As DAO.Recordset
   
   Dim DAO_PRO                      As DAO.Property
   Dim DAO_PROS                     As Object
   Dim strDes                       As String
   
   On Local Error GoTo GetErr
   
   Set DAO_WORK = DBEngine.CreateWorkspace("DAO_WORK", "admin", vbNullString)
   '打开数据库
   Set DB = DAO_WORK.OpenDatabase(strFileName, False, True, vbNullString)
   
   Set DAO_Rset = DB.OpenRecordset(strTable, dbOpenTable)
   Set DAO_PROS = DAO_Rset.Properties

   '取得描述值
   For Each DAO_PRO In DAO_PROS
      If DAO_PRO.Name = "Description" Then
         strDes = GetPropertyValue(DAO_PRO)
         GetTabDescription = strDes
         Exit For
      End If
   Next
   
   Set DB = Nothing
   Set DAO_Rset = Nothing
   Set DAO_PROS = Nothing
   Set DAO_PRO = Nothing
   
   Exit Function
   
GetErr:
   '如果为3270 错误为此字段无说明
   GetTabDescription = ""
   Set DB = Nothing
   Set DAO_Rset = Nothing
   Set DAO_PROS = Nothing
   Set DAO_PRO = Nothing
End Function

'取得字段的某个指定的属性
Function GetPropertyValue(prpObj As DAO.Property) As String
   On Error Resume Next

   Dim vTmp                         As Variant

   vTmp = prpObj.Value
   If Err Then
      Err.Clear
      GetPropertyValue = "N/A"
   Else
      GetPropertyValue = vTmp
   End If

End Function

'取得ACCESS数据库里的字段的描述值
'先引用 Microsoft DAO 3.6 Object Library
'参数说明:
'         strFileName         完整文件名
'         strTable            要取某个字段所在的表名
'         strField            要取得描述的字段名
'返    回:
'         此字段的描述值,如果没有返回名称
'例    子:
'         strDes=GetDescription("C:\data.mdb", "MyTab", "MyName")
Public Function GetDescription(ByVal strFileName As String, _
                               ByVal strTable As String, _
                               ByVal strField As String) As String
   Dim DB                           As Database                   '定义数据库
   Dim DAO_Rset                     As DAO.Recordset              '定义DAO记录集

   On Local Error GoTo GetErr
   
   '打开数据库
   Set DB = OpenDatabase(strFileName)
   '打开表
   Set DAO_Rset = DB.OpenRecordset(strTable, dbOpenTable)
   '取得描述值
   GetDescription = DAO_Rset(strField).Properties("Description").Value
   
   Set DB = Nothing
   Set DAO_Rset = Nothing
   
   Exit Function
   
GetErr:
   '如果为3270 错误为此字段无说明
   GetDescription = strField
   Set DB = Nothing
   Set DAO_Rset = Nothing
End Function